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