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