ghc/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 Packages         ( PackageIdH(..) )
  18 import Class            ( DefMeth(..) )
  19 import CostCentre
  20 import DriverState      ( v_Build_tag )
  21 import CmdLineOpts      ( opt_HiVersion )
  22 import Kind             ( Kind(..) )
  23 import Panic
  24 import Binary
  25 import Util
  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_package   = _, -- we ignore the package on output
 100                  mi_orphan    = orphan,
 101                  mi_deps      = deps,
 102                  mi_usages    = usages,
 103                  mi_exports   = exports,
 104                  mi_exp_vers  = exp_vers,
 105                  mi_fixities  = fixities,
 106                  mi_deprecs   = deprecs,
 107                  mi_decls     = decls,
 108                  mi_insts     = insts,
 109                  mi_rules     = rules,
 110                  mi_rule_vers = rule_vers }) = do
 111         put_ bh (show opt_HiVersion)
 112         build_tag <- readIORef v_Build_tag
 113         put  bh build_tag
 114         put_ bh mod
 115         put_ bh is_boot
 116         put_ bh mod_vers
 117         put_ bh orphan
 118         lazyPut bh deps
 119         lazyPut bh usages
 120         put_ bh exports
 121         put_ bh exp_vers
 122         put_ bh fixities
 123         lazyPut bh deprecs
 124         put_ bh decls
 125         put_ bh 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         build_tag <- readIORef v_Build_tag
 142         when (not ignore_way && check_way /= build_tag) $
 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                 ++ build_tag ++ ", 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         rules     <- {-# SCC "bin_rules" #-} lazyGet bh
 162         rule_vers <- get bh
 163         return (ModIface {
 164                  mi_package   = HomePackage, -- to be filled in properly later
 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_insts     = insts,
 177                  mi_rules     = rules,
 178                  mi_rule_vers = rule_vers,
 179                         -- And build the cached values
 180                  mi_dep_fn = mkIfaceDepCache deprecs,
 181                  mi_fix_fn = mkIfaceFixCache fixities,
 182                  mi_ver_fn = mkIfaceVerCache decls })
 183
 184 GLOBAL_VAR(v_IgnoreHiWay, False, Bool)
 185
 186 -------------------------------------------------------------------------
 187 --              Types from: HscTypes
 188 -------------------------------------------------------------------------
 189
 190 instance Binary Dependencies where
 191     put_ bh deps = do put_ bh (dep_mods deps)
 192                       put_ bh (dep_pkgs deps)
 193                       put_ bh (dep_orphs deps)
 194
 195     get bh = do ms <- get bh
 196                 ps <- get bh
 197                 os <- get bh
 198                 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os })
 199
 200 instance (Binary name) => Binary (GenAvailInfo name) where
 201     put_ bh (Avail aa) = do
 202             putByte bh 0
 203             put_ bh aa
 204     put_ bh (AvailTC ab ac) = do
 205             putByte bh 1
 206             put_ bh ab
 207             put_ bh ac
 208     get bh = do
 209             h <- getByte bh
 210             case h of
 211               0 -> do aa <- get bh
 212                       return (Avail aa)
 213               _ -> do ab <- get bh
 214                       ac <- get bh
 215                       return (AvailTC ab ac)
 216
 217 instance Binary Usage where
 218     put_ bh usg = do
 219         put_ bh (usg_name     usg)
 220         put_ bh (usg_mod      usg)
 221         put_ bh (usg_exports  usg)
 222         put_ bh (usg_entities usg)
 223         put_ bh (usg_rules    usg)
 224
 225     get bh = do
 226         nm    <- get bh
 227         mod   <- get bh
 228         exps  <- get bh
 229         ents  <- get bh
 230         rules <- get bh
 231         return (Usage { usg_name = nm, usg_mod = mod,
 232                         usg_exports = exps, usg_entities = ents,
 233                         usg_rules = rules })
 234
 235 instance Binary a => Binary (Deprecs a) where
 236     put_ bh NoDeprecs     = putByte bh 0
 237     put_ bh (DeprecAll t) = do
 238             putByte bh 1
 239             put_ bh t
 240     put_ bh (DeprecSome ts) = do
 241             putByte bh 2
 242             put_ bh ts
 243
 244     get bh = do
 245             h <- getByte bh
 246             case h of
 247               0 -> return NoDeprecs
 248               1 -> do aa <- get bh
 249                       return (DeprecAll aa)
 250               _ -> do aa <- get bh
 251                       return (DeprecSome aa)
 252
 253 -------------------------------------------------------------------------
 254 --              Types from: BasicTypes
 255 -------------------------------------------------------------------------
 256
 257 instance Binary Activation where
 258     put_ bh NeverActive = do
 259             putByte bh 0
 260     put_ bh AlwaysActive = do
 261             putByte bh 1
 262     put_ bh (ActiveBefore aa) = do
 263             putByte bh 2
 264             put_ bh aa
 265     put_ bh (ActiveAfter ab) = do
 266             putByte bh 3
 267             put_ bh ab
 268     get bh = do
 269             h <- getByte bh
 270             case h of
 271               0 -> do return NeverActive
 272               1 -> do return AlwaysActive
 273               2 -> do aa <- get bh
 274                       return (ActiveBefore aa)
 275               _ -> do ab <- get bh
 276                       return (ActiveAfter ab)
 277
 278 instance Binary StrictnessMark where
 279     put_ bh MarkedStrict = do
 280             putByte bh 0
 281     put_ bh MarkedUnboxed = do
 282             putByte bh 1
 283     put_ bh NotMarkedStrict = do
 284             putByte bh 2
 285     get bh = do
 286             h <- getByte bh
 287             case h of
 288               0 -> do return MarkedStrict
 289               1 -> do return MarkedUnboxed
 290               _ -> do return NotMarkedStrict
 291
 292 instance Binary Boxity where
 293     put_ bh Boxed = do
 294             putByte bh 0
 295     put_ bh Unboxed = do
 296             putByte bh 1
 297     get bh = do
 298             h <- getByte bh
 299             case h of
 300               0 -> do return Boxed
 301               _ -> do return Unboxed
 302
 303 instance Binary TupCon where
 304     put_ bh (TupCon ab ac) = do
 305             put_ bh ab
 306             put_ bh ac
 307     get bh = do
 308           ab <- get bh
 309           ac <- get bh
 310           return (TupCon ab ac)
 311
 312 instance Binary RecFlag where
 313     put_ bh Recursive = do
 314             putByte bh 0
 315     put_ bh NonRecursive = do
 316             putByte bh 1
 317     get bh = do
 318             h <- getByte bh
 319             case h of
 320               0 -> do return Recursive
 321               _ -> do return NonRecursive
 322
 323 instance Binary DefMeth where
 324     put_ bh NoDefMeth  = putByte bh 0
 325     put_ bh DefMeth    = putByte bh 1
 326     put_ bh GenDefMeth = putByte bh 2
 327     get bh = do
 328             h <- getByte bh
 329             case h of
 330               0 -> return NoDefMeth
 331               1 -> return DefMeth
 332               _ -> return GenDefMeth
 333
 334 instance Binary FixityDirection where
 335     put_ bh InfixL = do
 336             putByte bh 0
 337     put_ bh InfixR = do
 338             putByte bh 1
 339     put_ bh InfixN = do
 340             putByte bh 2
 341     get bh = do
 342             h <- getByte bh
 343             case h of
 344               0 -> do return InfixL
 345               1 -> do return InfixR
 346               _ -> do return InfixN
 347
 348 instance Binary Fixity where
 349     put_ bh (Fixity aa ab) = do
 350             put_ bh aa
 351             put_ bh ab
 352     get bh = do
 353           aa <- get bh
 354           ab <- get bh
 355           return (Fixity aa ab)
 356
 357 instance (Binary name) => Binary (IPName name) where
 358     put_ bh (Dupable aa) = do
 359             putByte bh 0
 360             put_ bh aa
 361     put_ bh (Linear ab) = do
 362             putByte bh 1
 363             put_ bh ab
 364     get bh = do
 365             h <- getByte bh
 366             case h of
 367               0 -> do aa <- get bh
 368                       return (Dupable aa)
 369               _ -> do ab <- get bh
 370                       return (Linear ab)
 371
 372 -------------------------------------------------------------------------
 373 --              Types from: Demand
 374 -------------------------------------------------------------------------
 375
 376 instance Binary DmdType where
 377         -- Ignore DmdEnv when spitting out the DmdType
 378   put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
 379   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
 380
 381 instance Binary Demand where
 382     put_ bh Top = do
 383             putByte bh 0
 384     put_ bh Abs = do
 385             putByte bh 1
 386     put_ bh (Call aa) = do
 387             putByte bh 2
 388             put_ bh aa
 389     put_ bh (Eval ab) = do
 390             putByte bh 3
 391             put_ bh ab
 392     put_ bh (Defer ac) = do
 393             putByte bh 4
 394             put_ bh ac
 395     put_ bh (Box ad) = do
 396             putByte bh 5
 397             put_ bh ad
 398     put_ bh Bot = do
 399             putByte bh 6
 400     get bh = do
 401             h <- getByte bh
 402             case h of
 403               0 -> do return Top
 404               1 -> do return Abs
 405               2 -> do aa <- get bh
 406                       return (Call aa)
 407               3 -> do ab <- get bh
 408                       return (Eval ab)
 409               4 -> do ac <- get bh
 410                       return (Defer ac)
 411               5 -> do ad <- get bh
 412                       return (Box ad)
 413               _ -> do return Bot
 414
 415 instance Binary Demands where
 416     put_ bh (Poly aa) = do
 417             putByte bh 0
 418             put_ bh aa
 419     put_ bh (Prod ab) = do
 420             putByte bh 1
 421             put_ bh ab
 422     get bh = do
 423             h <- getByte bh
 424             case h of
 425               0 -> do aa <- get bh
 426                       return (Poly aa)
 427               _ -> do ab <- get bh
 428                       return (Prod ab)
 429
 430 instance Binary DmdResult where
 431     put_ bh TopRes = do
 432             putByte bh 0
 433     put_ bh RetCPR = do
 434             putByte bh 1
 435     put_ bh BotRes = do
 436             putByte bh 2
 437     get bh = do
 438             h <- getByte bh
 439             case h of
 440               0 -> do return TopRes
 441               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 442                                         -- The wrapper was generated for CPR in
 443                                         -- the imported module!
 444               _ -> do return BotRes
 445
 446 instance Binary StrictSig where
 447     put_ bh (StrictSig aa) = do
 448             put_ bh aa
 449     get bh = do
 450           aa <- get bh
 451           return (StrictSig aa)
 452
 453
 454 -------------------------------------------------------------------------
 455 --              Types from: CostCentre
 456 -------------------------------------------------------------------------
 457
 458 instance Binary IsCafCC where
 459     put_ bh CafCC = do
 460             putByte bh 0
 461     put_ bh NotCafCC = do
 462             putByte bh 1
 463     get bh = do
 464             h <- getByte bh
 465             case h of
 466               0 -> do return CafCC
 467               _ -> do return NotCafCC
 468
 469 instance Binary IsDupdCC where
 470     put_ bh OriginalCC = do
 471             putByte bh 0
 472     put_ bh DupdCC = do
 473             putByte bh 1
 474     get bh = do
 475             h <- getByte bh
 476             case h of
 477               0 -> do return OriginalCC
 478               _ -> do return DupdCC
 479
 480 instance Binary CostCentre where
 481     put_ bh NoCostCentre = do
 482             putByte bh 0
 483     put_ bh (NormalCC aa ab ac ad) = do
 484             putByte bh 1
 485             put_ bh aa
 486             put_ bh ab
 487             put_ bh ac
 488             put_ bh ad
 489     put_ bh (AllCafsCC ae) = do
 490             putByte bh 2
 491             put_ bh ae
 492     get bh = do
 493             h <- getByte bh
 494             case h of
 495               0 -> do return NoCostCentre
 496               1 -> do aa <- get bh
 497                       ab <- get bh
 498                       ac <- get bh
 499                       ad <- get bh
 500                       return (NormalCC aa ab ac ad)
 501               _ -> do ae <- get bh
 502                       return (AllCafsCC ae)
 503
 504 -------------------------------------------------------------------------
 505 --              IfaceTypes and friends
 506 -------------------------------------------------------------------------
 507
 508 instance Binary IfaceExtName where
 509     put_ bh (ExtPkg mod occ) = do
 510             putByte bh 0
 511             put_ bh mod
 512             put_ bh occ
 513     put_ bh (HomePkg mod occ vers) = do
 514             putByte bh 1
 515             put_ bh mod
 516             put_ bh occ
 517             put_ bh vers
 518     put_ bh (LocalTop occ) = do
 519             putByte bh 2
 520             put_ bh occ
 521     put_ bh (LocalTopSub occ _) = do    -- Write LocalTopSub just like LocalTop
 522             putByte bh 2
 523             put_ bh occ
 524
 525     get bh = do
 526             h <- getByte bh
 527             case h of
 528               0 -> do mod <- get bh
 529                       occ <- get bh
 530                       return (ExtPkg mod occ)
 531               1 -> do mod <- get bh
 532                       occ <- get bh
 533                       vers <- get bh
 534                       return (HomePkg mod occ vers)
 535               _ -> do occ <- get bh
 536                       return (LocalTop occ)
 537
 538 instance Binary IfaceBndr where
 539     put_ bh (IfaceIdBndr aa) = do
 540             putByte bh 0
 541             put_ bh aa
 542     put_ bh (IfaceTvBndr ab) = do
 543             putByte bh 1
 544             put_ bh ab
 545     get bh = do
 546             h <- getByte bh
 547             case h of
 548               0 -> do aa <- get bh
 549                       return (IfaceIdBndr aa)
 550               _ -> do ab <- get bh
 551                       return (IfaceTvBndr ab)
 552
 553 instance Binary Kind where
 554     put_ bh LiftedTypeKind   = putByte bh 0
 555     put_ bh UnliftedTypeKind = putByte bh 1
 556     put_ bh OpenTypeKind     = putByte bh 2
 557     put_ bh ArgTypeKind      = putByte bh 3
 558     put_ bh UbxTupleKind     = putByte bh 4
 559     put_ bh (FunKind k1 k2)  = do
 560             putByte bh 5
 561             put_ bh k1
 562             put_ bh k2
 563     put_ bh (KindVar kv) = pprPanic "BinIface.put_: kind var" (ppr kv)
 564
 565     get bh = do
 566             h <- getByte bh
 567             case h of
 568               0 -> return LiftedTypeKind
 569               1 -> return UnliftedTypeKind
 570               2 -> return OpenTypeKind
 571               3 -> return ArgTypeKind
 572               4 -> return UbxTupleKind
 573               _ -> do k1 <- get bh
 574                       k2 <- get bh
 575                       return (FunKind k1 k2)
 576
 577 instance Binary IfaceType where
 578     put_ bh (IfaceForAllTy aa ab) = do
 579             putByte bh 0
 580             put_ bh aa
 581             put_ bh ab
 582     put_ bh (IfaceTyVar ad) = do
 583             putByte bh 1
 584             put_ bh ad
 585     put_ bh (IfaceAppTy ae af) = do
 586             putByte bh 2
 587             put_ bh ae
 588             put_ bh af
 589     put_ bh (IfaceFunTy ag ah) = do
 590             putByte bh 3
 591             put_ bh ag
 592             put_ bh ah
 593     put_ bh (IfacePredTy aq) = do
 594             putByte bh 5
 595             put_ bh aq
 596
 597         -- Simple compression for common cases of TyConApp
 598     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
 599     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
 600     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
 601     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
 602         -- Unit tuple and pairs
 603     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])      = putByte bh 10
 604     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
 605         -- Generic cases
 606     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
 607     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 13; put_ bh tc; put_ bh tys }
 608
 609     get bh = do
 610             h <- getByte bh
 611             case h of
 612               0 -> do aa <- get bh
 613                       ab <- get bh
 614                       return (IfaceForAllTy aa ab)
 615               1 -> do ad <- get bh
 616                       return (IfaceTyVar ad)
 617               2 -> do ae <- get bh
 618                       af <- get bh
 619                       return (IfaceAppTy ae af)
 620               3 -> do ag <- get bh
 621                       ah <- get bh
 622                       return (IfaceFunTy ag ah)
 623               5 -> do ap <- get bh
 624                       return (IfacePredTy ap)
 625
 626                 -- Now the special cases for TyConApp
 627               6 -> return (IfaceTyConApp IfaceIntTc [])
 628               7 -> return (IfaceTyConApp IfaceCharTc [])
 629               8 -> return (IfaceTyConApp IfaceBoolTc [])
 630               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 631               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 632               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 633               12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 634               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 635
 636 instance Binary IfaceTyCon where
 637         -- Int,Char,Bool can't show up here because they can't not be saturated
 638    put_ bh IfaceListTc = putByte bh 1
 639    put_ bh IfacePArrTc = putByte bh 2
 640    put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
 641    put_ bh tc = pprPanic "BinIface.put:" (ppr tc)       -- Dealt with by the IfaceType instance
 642
 643    get bh = do
 644         h <- getByte bh
 645         case h of
 646           1 -> return IfaceListTc
 647           2 -> return IfacePArrTc
 648           _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 649
 650 instance Binary IfacePredType where
 651     put_ bh (IfaceClassP aa ab) = do
 652             putByte bh 0
 653             put_ bh aa
 654             put_ bh ab
 655     put_ bh (IfaceIParam ac ad) = do
 656             putByte bh 1
 657             put_ bh ac
 658             put_ bh ad
 659     get bh = do
 660             h <- getByte bh
 661             case h of
 662               0 -> do aa <- get bh
 663                       ab <- get bh
 664                       return (IfaceClassP aa ab)
 665               _ -> do ac <- get bh
 666                       ad <- get bh
 667                       return (IfaceIParam ac ad)
 668
 669 -------------------------------------------------------------------------
 670 --              IfaceExpr and friends
 671 -------------------------------------------------------------------------
 672
 673 instance Binary IfaceExpr where
 674     put_ bh (IfaceLcl aa) = do
 675             putByte bh 0
 676             put_ bh aa
 677     put_ bh (IfaceType ab) = do
 678             putByte bh 1
 679             put_ bh ab
 680     put_ bh (IfaceTuple ac ad) = do
 681             putByte bh 2
 682             put_ bh ac
 683             put_ bh ad
 684     put_ bh (IfaceLam ae af) = do
 685             putByte bh 3
 686             put_ bh ae
 687             put_ bh af
 688     put_ bh (IfaceApp ag ah) = do
 689             putByte bh 4
 690             put_ bh ag
 691             put_ bh ah
 692 -- gaw 2004
 693     put_ bh (IfaceCase ai aj al ak) = do
 694             putByte bh 5
 695             put_ bh ai
 696             put_ bh aj
 697 -- gaw 2004
 698             put_ bh al
 699             put_ bh ak
 700     put_ bh (IfaceLet al am) = do
 701             putByte bh 6
 702             put_ bh al
 703             put_ bh am
 704     put_ bh (IfaceNote an ao) = do
 705             putByte bh 7
 706             put_ bh an
 707             put_ bh ao
 708     put_ bh (IfaceLit ap) = do
 709             putByte bh 8
 710             put_ bh ap
 711     put_ bh (IfaceFCall as at) = do
 712             putByte bh 9
 713             put_ bh as
 714             put_ bh at
 715     put_ bh (IfaceExt aa) = do
 716             putByte bh 10
 717             put_ bh aa
 718     get bh = do
 719             h <- getByte bh
 720             case h of
 721               0 -> do aa <- get bh
 722                       return (IfaceLcl aa)
 723               1 -> do ab <- get bh
 724                       return (IfaceType ab)
 725               2 -> do ac <- get bh
 726                       ad <- get bh
 727                       return (IfaceTuple ac ad)
 728               3 -> do ae <- get bh
 729                       af <- get bh
 730                       return (IfaceLam ae af)
 731               4 -> do ag <- get bh
 732                       ah <- get bh
 733                       return (IfaceApp ag ah)
 734               5 -> do ai <- get bh
 735                       aj <- get bh
 736 -- gaw 2004
 737                       al <- get bh
 738                       ak <- get bh
 739 -- gaw 2004
 740                       return (IfaceCase ai aj al ak)
 741               6 -> do al <- get bh
 742                       am <- get bh
 743                       return (IfaceLet al am)
 744               7 -> do an <- get bh
 745                       ao <- get bh
 746                       return (IfaceNote an ao)
 747               8 -> do ap <- get bh
 748                       return (IfaceLit ap)
 749               9 -> do as <- get bh
 750                       at <- get bh
 751                       return (IfaceFCall as at)
 752               _ -> do aa <- get bh
 753                       return (IfaceExt aa)
 754
 755 instance Binary IfaceConAlt where
 756     put_ bh IfaceDefault = do
 757             putByte bh 0
 758     put_ bh (IfaceDataAlt aa) = do
 759             putByte bh 1
 760             put_ bh aa
 761     put_ bh (IfaceTupleAlt ab) = do
 762             putByte bh 2
 763             put_ bh ab
 764     put_ bh (IfaceLitAlt ac) = do
 765             putByte bh 3
 766             put_ bh ac
 767     get bh = do
 768             h <- getByte bh
 769             case h of
 770               0 -> do return IfaceDefault
 771               1 -> do aa <- get bh
 772                       return (IfaceDataAlt aa)
 773               2 -> do ab <- get bh
 774                       return (IfaceTupleAlt ab)
 775               _ -> do ac <- get bh
 776                       return (IfaceLitAlt ac)
 777
 778 instance Binary IfaceBinding where
 779     put_ bh (IfaceNonRec aa ab) = do
 780             putByte bh 0
 781             put_ bh aa
 782             put_ bh ab
 783     put_ bh (IfaceRec ac) = do
 784             putByte bh 1
 785             put_ bh ac
 786     get bh = do
 787             h <- getByte bh
 788             case h of
 789               0 -> do aa <- get bh
 790                       ab <- get bh
 791                       return (IfaceNonRec aa ab)
 792               _ -> do ac <- get bh
 793                       return (IfaceRec ac)
 794
 795 instance Binary IfaceIdInfo where
 796     put_ bh NoInfo = putByte bh 0
 797     put_ bh (HasInfo i) = do
 798             putByte bh 1
 799             lazyPut bh i
 800
 801     get bh = do
 802             h <- getByte bh
 803             case h of
 804               0 -> return NoInfo
 805               _ -> do info <- lazyGet bh
 806                       return (HasInfo info)
 807
 808 instance Binary IfaceInfoItem where
 809     put_ bh (HsArity aa) = do
 810             putByte bh 0
 811             put_ bh aa
 812     put_ bh (HsStrictness ab) = do
 813             putByte bh 1
 814             put_ bh ab
 815     put_ bh (HsUnfold ac ad) = do
 816             putByte bh 2
 817             put_ bh ac
 818             put_ bh ad
 819     put_ bh HsNoCafRefs = do
 820             putByte bh 3
 821     put_ bh (HsWorker ae af) = do
 822             putByte bh 4
 823             put_ bh ae
 824             put_ bh af
 825     get bh = do
 826             h <- getByte bh
 827             case h of
 828               0 -> do aa <- get bh
 829                       return (HsArity aa)
 830               1 -> do ab <- get bh
 831                       return (HsStrictness ab)
 832               2 -> do ac <- get bh
 833                       ad <- get bh
 834                       return (HsUnfold ac ad)
 835               3 -> do return HsNoCafRefs
 836               _ -> do ae <- get bh
 837                       af <- get bh
 838                       return (HsWorker ae af)
 839
 840 instance Binary IfaceNote where
 841     put_ bh (IfaceSCC aa) = do
 842             putByte bh 0
 843             put_ bh aa
 844     put_ bh (IfaceCoerce ab) = do
 845             putByte bh 1
 846             put_ bh ab
 847     put_ bh IfaceInlineCall = do
 848             putByte bh 2
 849     put_ bh IfaceInlineMe = do
 850             putByte bh 3
 851     put_ bh (IfaceCoreNote s) = do
 852             putByte bh 4
 853             put_ bh s
 854     get bh = do
 855             h <- getByte bh
 856             case h of
 857               0 -> do aa <- get bh
 858                       return (IfaceSCC aa)
 859               1 -> do ab <- get bh
 860                       return (IfaceCoerce ab)
 861               2 -> do return IfaceInlineCall
 862               3 -> do return IfaceInlineMe
 863               _ -> do ac <- get bh
 864                       return (IfaceCoreNote ac)
 865
 866
 867 -------------------------------------------------------------------------
 868 --              IfaceDecl and friends
 869 -------------------------------------------------------------------------
 870
 871 instance Binary IfaceDecl where
 872     put_ bh (IfaceId name ty idinfo) = do
 873             putByte bh 0
 874             put_ bh name
 875             put_ bh ty
 876             put_ bh idinfo
 877     put_ bh (IfaceForeign ae af) =
 878         error "Binary.put_(IfaceDecl): IfaceForeign"
 879     put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do
 880             putByte bh 2
 881             put_ bh a1
 882             put_ bh a2
 883             put_ bh a3
 884             put_ bh a4
 885             put_ bh a5
 886             put_ bh a6
 887
 888     put_ bh (IfaceSyn aq ar as at) = do
 889             putByte bh 3
 890             put_ bh aq
 891             put_ bh ar
 892             put_ bh as
 893             put_ bh at
 894     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
 895             putByte bh 4
 896             put_ bh a1
 897             put_ bh a2
 898             put_ bh a3
 899             put_ bh a4
 900             put_ bh a5
 901             put_ bh a6
 902             put_ bh a7
 903     get bh = do
 904             h <- getByte bh
 905             case h of
 906               0 -> do name   <- get bh
 907                       ty     <- get bh
 908                       idinfo <- get bh
 909                       return (IfaceId name ty idinfo)
 910               1 -> error "Binary.get(TyClDecl): ForeignType"
 911               2 -> do
 912                     a1 <- get bh
 913                     a2 <- get bh
 914                     a3 <- get bh
 915                     a4 <- get bh
 916                     a5 <- get bh
 917                     a6 <- get bh
 918                     return (IfaceData a1 a2 a3 a4 a5 a6)
 919               3 -> do
 920                     aq <- get bh
 921                     ar <- get bh
 922                     as <- get bh
 923                     at <- get bh
 924                     return (IfaceSyn aq ar as at)
 925               _ -> do
 926                     a1 <- get bh
 927                     a2 <- get bh
 928                     a3 <- get bh
 929                     a4 <- get bh
 930                     a5 <- get bh
 931                     a6 <- get bh
 932                     a7 <- get bh
 933                     return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
 934
 935 instance Binary IfaceInst where
 936     put_ bh (IfaceInst ty dfun) = do
 937             put_ bh ty
 938             put_ bh dfun
 939     get bh = do ty   <- get bh
 940                 dfun <- get bh
 941                 return (IfaceInst ty dfun)
 942
 943 instance Binary IfaceConDecls where
 944     put_ bh IfAbstractTyCon = putByte bh 0
 945     put_ bh (IfDataTyCon st cs) = do { putByte bh 1
 946                                      ; put_ bh st
 947                                      ; put_ bh cs }
 948     put_ bh (IfNewTyCon c)  = do { putByte bh 2
 949                                   ; put_ bh c }
 950     get bh = do
 951             h <- getByte bh
 952             case h of
 953               0 -> return IfAbstractTyCon
 954               1 -> do st <- get bh
 955                       cs <- get bh
 956                       return (IfDataTyCon st cs)
 957               _ -> do aa <- get bh
 958                       return (IfNewTyCon aa)
 959
 960 instance Binary IfaceConDecl where
 961     put_ bh (IfVanillaCon a1 a2 a3 a4 a5) = do
 962             putByte bh 0
 963             put_ bh a1
 964             put_ bh a2
 965             put_ bh a3
 966             put_ bh a4
 967             put_ bh a5
 968     put_ bh (IfGadtCon a1 a2 a3 a4 a5 a6) = do
 969             putByte bh 1
 970             put_ bh a1
 971             put_ bh a2
 972             put_ bh a3
 973             put_ bh a4
 974             put_ bh a5
 975             put_ bh a6
 976     get bh = do
 977             h <- getByte bh
 978             case h of
 979               0 -> do a1 <- get bh
 980                       a2 <- get bh
 981                       a3 <- get bh
 982                       a4 <- get bh
 983                       a5 <- get bh
 984                       return (IfVanillaCon a1 a2 a3 a4 a5)
 985               _ -> do a1 <- get bh
 986                       a2 <- get bh
 987                       a3 <- get bh
 988                       a4 <- get bh
 989                       a5 <- get bh
 990                       a6 <- get bh
 991                       return (IfGadtCon a1 a2 a3 a4 a5 a6)
 992
 993 instance Binary IfaceClassOp where
 994    put_ bh (IfaceClassOp n def ty) = do
 995         put_ bh n
 996         put_ bh def
 997         put_ bh ty
 998    get bh = do
 999         n <- get bh
1000         def <- get bh
1001         ty <- get bh
1002         return (IfaceClassOp n def ty)
1003
1004 instance Binary IfaceRule where
1005         -- IfaceBuiltinRule should not happen here
1006     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
1007             put_ bh a1
1008             put_ bh a2
1009             put_ bh a3
1010             put_ bh a4
1011             put_ bh a5
1012             put_ bh a6
1013     get bh = do
1014             a1 <- get bh
1015             a2 <- get bh
1016             a3 <- get bh
1017             a4 <- get bh
1018             a5 <- get bh
1019             a6 <- get bh
1020             return (IfaceRule a1 a2 a3 a4 a5 a6)
1021
1022