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