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