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