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