ghc/compiler/iface/BinIface.hs

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