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