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