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