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 OccName          ( OccName )
  22 import DriverState      ( v_Build_tag )
  23 import CmdLineOpts      ( opt_HiVersion )
  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 IfaceKind where
 574     put_ bh IfaceLiftedTypeKind   = putByte bh 0
 575     put_ bh IfaceUnliftedTypeKind = putByte bh 1
 576     put_ bh IfaceOpenTypeKind     = putByte bh 2
 577     put_ bh (IfaceFunKind k1 k2)  = do
 578             putByte bh 3
 579             put_ bh k1
 580             put_ bh k2
 581     get bh = do
 582             h <- getByte bh
 583             case h of
 584               0 -> return IfaceLiftedTypeKind
 585               1 -> return IfaceUnliftedTypeKind
 586               2 -> return IfaceOpenTypeKind
 587               _ -> do k1 <- get bh
 588                       k2 <- get bh
 589                       return (IfaceFunKind k1 k2)
 590
 591 instance Binary IfaceType where
 592     put_ bh (IfaceForAllTy aa ab) = do
 593             putByte bh 0
 594             put_ bh aa
 595             put_ bh ab
 596     put_ bh (IfaceTyVar ad) = do
 597             putByte bh 1
 598             put_ bh ad
 599     put_ bh (IfaceAppTy ae af) = do
 600             putByte bh 2
 601             put_ bh ae
 602             put_ bh af
 603     put_ bh (IfaceFunTy ag ah) = do
 604             putByte bh 3
 605             put_ bh ag
 606             put_ bh ah
 607     put_ bh (IfacePredTy aq) = do
 608             putByte bh 5
 609             put_ bh aq
 610
 611         -- Simple compression for common cases of TyConApp
 612     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
 613     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
 614     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
 615     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
 616         -- Unit tuple and pairs
 617     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])      = putByte bh 10
 618     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
 619         -- Generic cases
 620     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 12; put_ bh tc; put_ bh tys }
 621     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 13; put_ bh tc; put_ bh tys }
 622
 623     get bh = do
 624             h <- getByte bh
 625             case h of
 626               0 -> do aa <- get bh
 627                       ab <- get bh
 628                       return (IfaceForAllTy aa ab)
 629               1 -> do ad <- get bh
 630                       return (IfaceTyVar ad)
 631               2 -> do ae <- get bh
 632                       af <- get bh
 633                       return (IfaceAppTy ae af)
 634               3 -> do ag <- get bh
 635                       ah <- get bh
 636                       return (IfaceFunTy ag ah)
 637               5 -> do ap <- get bh
 638                       return (IfacePredTy ap)
 639
 640                 -- Now the special cases for TyConApp
 641               6 -> return (IfaceTyConApp IfaceIntTc [])
 642               7 -> return (IfaceTyConApp IfaceCharTc [])
 643               8 -> return (IfaceTyConApp IfaceBoolTc [])
 644               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 645               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 646               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 647               12 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 648               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 649
 650 instance Binary IfaceTyCon where
 651         -- Int,Char,Bool can't show up here because they can't not be saturated
 652    put_ bh IfaceListTc = putByte bh 1
 653    put_ bh IfacePArrTc = putByte bh 2
 654    put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar }
 655    put_ bh tc = pprPanic "BinIface.put:" (ppr tc)       -- Dealt with by the IfaceType instance
 656
 657    get bh = do
 658         h <- getByte bh
 659         case h of
 660           1 -> return IfaceListTc
 661           2 -> return IfacePArrTc
 662           _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 663
 664 instance Binary IfacePredType where
 665     put_ bh (IfaceClassP aa ab) = do
 666             putByte bh 0
 667             put_ bh aa
 668             put_ bh ab
 669     put_ bh (IfaceIParam ac ad) = do
 670             putByte bh 1
 671             put_ bh ac
 672             put_ bh ad
 673     get bh = do
 674             h <- getByte bh
 675             case h of
 676               0 -> do aa <- get bh
 677                       ab <- get bh
 678                       return (IfaceClassP aa ab)
 679               _ -> do ac <- get bh
 680                       ad <- get bh
 681                       return (IfaceIParam ac ad)
 682
 683 -------------------------------------------------------------------------
 684 --              IfaceExpr and friends
 685 -------------------------------------------------------------------------
 686
 687 instance Binary IfaceExpr where
 688     put_ bh (IfaceLcl aa) = do
 689             putByte bh 0
 690             put_ bh aa
 691     put_ bh (IfaceType ab) = do
 692             putByte bh 1
 693             put_ bh ab
 694     put_ bh (IfaceTuple ac ad) = do
 695             putByte bh 2
 696             put_ bh ac
 697             put_ bh ad
 698     put_ bh (IfaceLam ae af) = do
 699             putByte bh 3
 700             put_ bh ae
 701             put_ bh af
 702     put_ bh (IfaceApp ag ah) = do
 703             putByte bh 4
 704             put_ bh ag
 705             put_ bh ah
 706     put_ bh (IfaceCase ai aj ak) = do
 707             putByte bh 5
 708             put_ bh ai
 709             put_ bh aj
 710             put_ bh ak
 711     put_ bh (IfaceLet al am) = do
 712             putByte bh 6
 713             put_ bh al
 714             put_ bh am
 715     put_ bh (IfaceNote an ao) = do
 716             putByte bh 7
 717             put_ bh an
 718             put_ bh ao
 719     put_ bh (IfaceLit ap) = do
 720             putByte bh 8
 721             put_ bh ap
 722     put_ bh (IfaceFCall as at) = do
 723             putByte bh 9
 724             put_ bh as
 725             put_ bh at
 726     put_ bh (IfaceExt aa) = do
 727             putByte bh 10
 728             put_ bh aa
 729     get bh = do
 730             h <- getByte bh
 731             case h of
 732               0 -> do aa <- get bh
 733                       return (IfaceLcl aa)
 734               1 -> do ab <- get bh
 735                       return (IfaceType ab)
 736               2 -> do ac <- get bh
 737                       ad <- get bh
 738                       return (IfaceTuple ac ad)
 739               3 -> do ae <- get bh
 740                       af <- get bh
 741                       return (IfaceLam ae af)
 742               4 -> do ag <- get bh
 743                       ah <- get bh
 744                       return (IfaceApp ag ah)
 745               5 -> do ai <- get bh
 746                       aj <- get bh
 747                       ak <- get bh
 748                       return (IfaceCase ai aj ak)
 749               6 -> do al <- get bh
 750                       am <- get bh
 751                       return (IfaceLet al am)
 752               7 -> do an <- get bh
 753                       ao <- get bh
 754                       return (IfaceNote an ao)
 755               8 -> do ap <- get bh
 756                       return (IfaceLit ap)
 757               9 -> do as <- get bh
 758                       at <- get bh
 759                       return (IfaceFCall as at)
 760               _ -> do aa <- get bh
 761                       return (IfaceExt aa)
 762
 763 instance Binary IfaceConAlt where
 764     put_ bh IfaceDefault = do
 765             putByte bh 0
 766     put_ bh (IfaceDataAlt aa) = do
 767             putByte bh 1
 768             put_ bh aa
 769     put_ bh (IfaceTupleAlt ab) = do
 770             putByte bh 2
 771             put_ bh ab
 772     put_ bh (IfaceLitAlt ac) = do
 773             putByte bh 3
 774             put_ bh ac
 775     get bh = do
 776             h <- getByte bh
 777             case h of
 778               0 -> do return IfaceDefault
 779               1 -> do aa <- get bh
 780                       return (IfaceDataAlt aa)
 781               2 -> do ab <- get bh
 782                       return (IfaceTupleAlt ab)
 783               _ -> do ac <- get bh
 784                       return (IfaceLitAlt ac)
 785
 786 instance Binary IfaceBinding where
 787     put_ bh (IfaceNonRec aa ab) = do
 788             putByte bh 0
 789             put_ bh aa
 790             put_ bh ab
 791     put_ bh (IfaceRec ac) = do
 792             putByte bh 1
 793             put_ bh ac
 794     get bh = do
 795             h <- getByte bh
 796             case h of
 797               0 -> do aa <- get bh
 798                       ab <- get bh
 799                       return (IfaceNonRec aa ab)
 800               _ -> do ac <- get bh
 801                       return (IfaceRec ac)
 802
 803 instance Binary IfaceIdInfo where
 804     put_ bh NoInfo = putByte bh 0
 805     put_ bh (HasInfo i) = do
 806             putByte bh 1
 807             lazyPut bh i
 808     put_ bh DiscardedInfo = panic "BinIface:DiscardedInfo"
 809
 810     get bh = do
 811             h <- getByte bh
 812             case h of
 813               0 -> return NoInfo
 814               _ -> do info <- lazyGet bh
 815                       return (HasInfo info)
 816
 817 instance Binary IfaceInfoItem where
 818     put_ bh (HsArity aa) = do
 819             putByte bh 0
 820             put_ bh aa
 821     put_ bh (HsStrictness ab) = do
 822             putByte bh 1
 823             put_ bh ab
 824     put_ bh (HsUnfold ac ad) = do
 825             putByte bh 2
 826             put_ bh ac
 827             put_ bh ad
 828     put_ bh HsNoCafRefs = do
 829             putByte bh 3
 830     put_ bh (HsWorker ae af) = do
 831             putByte bh 4
 832             put_ bh ae
 833             put_ bh af
 834     get bh = do
 835             h <- getByte bh
 836             case h of
 837               0 -> do aa <- get bh
 838                       return (HsArity aa)
 839               1 -> do ab <- get bh
 840                       return (HsStrictness ab)
 841               2 -> do ac <- get bh
 842                       ad <- get bh
 843                       return (HsUnfold ac ad)
 844               3 -> do return HsNoCafRefs
 845               _ -> do ae <- get bh
 846                       af <- get bh
 847                       return (HsWorker ae af)
 848
 849 instance Binary IfaceNote where
 850     put_ bh (IfaceSCC aa) = do
 851             putByte bh 0
 852             put_ bh aa
 853     put_ bh (IfaceCoerce ab) = do
 854             putByte bh 1
 855             put_ bh ab
 856     put_ bh IfaceInlineCall = do
 857             putByte bh 2
 858     put_ bh IfaceInlineMe = do
 859             putByte bh 3
 860     put_ bh (IfaceCoreNote s) = do
 861             putByte bh 4
 862             put_ bh s
 863     get bh = do
 864             h <- getByte bh
 865             case h of
 866               0 -> do aa <- get bh
 867                       return (IfaceSCC aa)
 868               1 -> do ab <- get bh
 869                       return (IfaceCoerce ab)
 870               2 -> do return IfaceInlineCall
 871               3 -> do return IfaceInlineMe
 872               _ -> do ac <- get bh
 873                       return (IfaceCoreNote ac)
 874
 875
 876 -------------------------------------------------------------------------
 877 --              IfaceDecl and friends
 878 -------------------------------------------------------------------------
 879
 880 instance Binary IfaceDecl where
 881     put_ bh (IfaceId name ty idinfo) = do
 882             putByte bh 0
 883             put_ bh name
 884             put_ bh ty
 885             put_ bh idinfo
 886     put_ bh (IfaceForeign ae af) =
 887         error "Binary.put_(IfaceDecl): IfaceForeign"
 888     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
 889             putByte bh 2
 890             put_ bh a1
 891             put_ bh a2
 892             put_ bh a3
 893             put_ bh a4
 894             put_ bh a5
 895             put_ bh a6
 896             put_ bh a7
 897             put_ bh a8
 898
 899     put_ bh (IfaceSyn aq ar as at) = do
 900             putByte bh 3
 901             put_ bh aq
 902             put_ bh ar
 903             put_ bh as
 904             put_ bh at
 905     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
 906             putByte bh 4
 907             put_ bh a1
 908             put_ bh a2
 909             put_ bh a3
 910             put_ bh a4
 911             put_ bh a5
 912             put_ bh a6
 913             put_ bh a7
 914     get bh = do
 915             h <- getByte bh
 916             case h of
 917               0 -> do name   <- get bh
 918                       ty     <- get bh
 919                       idinfo <- get bh
 920                       return (IfaceId name ty idinfo)
 921               1 -> error "Binary.get(TyClDecl): ForeignType"
 922               2 -> 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                     a8 <- get bh
 931                     return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8)
 932               3 -> do
 933                     aq <- get bh
 934                     ar <- get bh
 935                     as <- get bh
 936                     at <- get bh
 937                     return (IfaceSyn aq ar as at)
 938               _ -> do
 939                     a1 <- get bh
 940                     a2 <- get bh
 941                     a3 <- get bh
 942                     a4 <- get bh
 943                     a5 <- get bh
 944                     a6 <- get bh
 945                     a7 <- get bh
 946                     return (IfaceClass a1 a2 a3 a4 a5 a6 a7)
 947
 948 instance Binary IfaceInst where
 949     put_ bh (IfaceInst ty dfun) = do
 950             put_ bh ty
 951             put_ bh dfun
 952     get bh = do ty   <- get bh
 953                 dfun <- get bh
 954                 return (IfaceInst ty dfun)
 955
 956 instance Binary IfaceConDecl where
 957     put_ bh (IfaceConDecl a1 a2 a3 a4 a5 a6) = do
 958             put_ bh a1
 959             put_ bh a2
 960             put_ bh a3
 961             put_ bh a4
 962             put_ bh a5
 963             put_ bh a6
 964     get bh = do
 965             a1 <- get bh
 966             a2 <- get bh
 967             a3 <- get bh
 968             a4 <- get bh
 969             a5 <- get bh
 970             a6 <- get bh
 971             return (IfaceConDecl a1 a2 a3 a4 a5 a6)
 972
 973 instance Binary IfaceClassOp where
 974    put_ bh (IfaceClassOp n def ty) = do
 975         put_ bh n
 976         put_ bh def
 977         put_ bh ty
 978    get bh = do
 979         n <- get bh
 980         def <- get bh
 981         ty <- get bh
 982         return (IfaceClassOp n def ty)
 983
 984 instance Binary IfaceRule where
 985         -- IfaceBuiltinRule should not happen here
 986     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do
 987             put_ bh a1
 988             put_ bh a2
 989             put_ bh a3
 990             put_ bh a4
 991             put_ bh a5
 992             put_ bh a6
 993     get bh = do
 994             a1 <- get bh
 995             a2 <- get bh
 996             a3 <- get bh
 997             a4 <- get bh
 998             a5 <- get bh
 999             a6 <- get bh
1000             return (IfaceRule a1 a2 a3 a4 a5 a6)
1001
1002 instance (Binary datacon) => Binary (DataConDetails datacon) where
1003     put_ bh (DataCons aa) = do
1004             putByte bh 0
1005             put_ bh aa
1006     put_ bh Unknown = do
1007             putByte bh 1
1008     get bh = do
1009             h <- getByte bh
1010             case h of
1011               0 -> do aa <- get bh
1012                       return (DataCons aa)
1013               _ -> do return Unknown
1014