compiler/iface/BinIface.hs

   1 {-# OPTIONS -w #-}
   2 -- The above warning supression flag is a temporary kludge.
   3 -- While working on this module you are encouraged to remove it and fix
   4 -- any warnings in the module. See
   5 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
   6 -- for details
   7
   8 --
   9 --  (c) The University of Glasgow 2002-2006
  10 --
  11 -- Binary interface file support.
  12
  13 module BinIface ( writeBinIface, readBinIface,
  14                   CheckHiWay(..), TraceBinIFaceReading(..) ) where
  15
  16 #include "HsVersions.h"
  17
  18 import TcRnMonad
  19 import IfaceEnv
  20 import HscTypes
  21 import BasicTypes
  22 import NewDemand
  23 import IfaceSyn
  24 import Module
  25 import Name
  26 import OccName
  27 import VarEnv
  28 import InstEnv
  29 import Class
  30 import DynFlags
  31 import UniqFM
  32 import UniqSupply
  33 import CostCentre
  34 import StaticFlags
  35 import PackageConfig
  36 import Panic
  37 import Binary
  38 import SrcLoc
  39 import Util
  40 import ErrUtils
  41 import Config
  42 import FastMutInt
  43 import Outputable
  44
  45 import Data.List
  46 import Data.Word
  47 import Data.Array
  48 import Data.IORef
  49 import Control.Exception
  50 import Control.Monad
  51
  52 data CheckHiWay = CheckHiWay | IgnoreHiWay
  53     deriving Eq
  54
  55 data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
  56     deriving Eq
  57
  58 -- ---------------------------------------------------------------------------
  59 -- Reading and writing binary interface files
  60
  61 readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
  62              -> TcRnIf a b ModIface
  63 readBinIface checkHiWay traceBinIFaceReading hi_path = do
  64   nc <- getNameCache
  65   (new_nc, iface) <- liftIO $
  66     readBinIface_ checkHiWay traceBinIFaceReading hi_path nc
  67   setNameCache new_nc
  68   return iface
  69
  70 readBinIface_ :: CheckHiWay -> TraceBinIFaceReading -> FilePath -> NameCache
  71               -> IO (NameCache, ModIface)
  72 readBinIface_ checkHiWay traceBinIFaceReading hi_path nc = do
  73   let printer :: SDoc -> IO ()
  74       printer = case traceBinIFaceReading of
  75                 TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
  76                 QuietBinIFaceReading -> \_ -> return ()
  77       wantedGot :: Outputable a => String -> a -> a -> IO ()
  78       wantedGot what wanted got
  79           = printer (text what <> text ": " <>
  80                      vcat [text "Wanted " <> ppr wanted <> text ",",
  81                            text "got    " <> ppr got])
  82   bh <- Binary.readBinMem hi_path
  83
  84         -- Read the magic number to check that this really is a GHC .hi file
  85         -- (This magic number does not change when we change
  86         --  GHC interface file format)
  87   magic <- get bh
  88   wantedGot "Magic" binaryInterfaceMagic magic
  89   when (magic /= binaryInterfaceMagic) $
  90         throwDyn (ProgramError (
  91            "magic number mismatch: old/corrupt interface file?"))
  92
  93         -- Get the dictionary pointer.  We won't attempt to actually
  94         -- read the dictionary until we've done the version checks below,
  95         -- just in case this isn't a valid interface.  In retrospect the
  96         -- version should have come before the dictionary pointer, but this
  97         -- is the way it was done originally, and we can't change it now.
  98   dict_p <- Binary.get bh       -- Get the dictionary ptr
  99
 100         -- Check the interface file version and ways.
 101   check_ver  <- get bh
 102   let our_ver = show opt_HiVersion
 103   wantedGot "Version" our_ver check_ver
 104   when (check_ver /= our_ver) $
 105         -- This will be caught by readIface which will emit an error
 106         -- msg containing the iface module name.
 107     throwDyn (ProgramError (
 108         "mismatched interface file versions: expected "
 109         ++ our_ver ++ ", found " ++ check_ver))
 110
 111   check_way <- get bh
 112   way_descr <- getWayDescr
 113   wantedGot "Way" way_descr check_way
 114   when (checkHiWay == CheckHiWay && check_way /= way_descr) $
 115         -- This will be caught by readIface
 116         -- which will emit an error msg containing the iface module name.
 117      throwDyn (ProgramError (
 118         "mismatched interface file ways: expected "
 119         ++ way_descr ++ ", found " ++ check_way))
 120
 121         -- Read the dictionary
 122         -- The next word in the file is a pointer to where the dictionary is
 123         -- (probably at the end of the file)
 124   data_p <- tellBin bh          -- Remember where we are now
 125   seekBin bh dict_p
 126   dict <- getDictionary bh
 127   seekBin bh data_p             -- Back to where we were before
 128
 129         -- Initialise the user-data field of bh
 130   ud <- newReadState dict
 131   bh <- return (setUserData bh ud)
 132
 133   symtab_p <- Binary.get bh     -- Get the symtab ptr
 134   data_p <- tellBin bh          -- Remember where we are now
 135   seekBin bh symtab_p
 136   (nc', symtab) <- getSymbolTable bh nc
 137   seekBin bh data_p             -- Back to where we were before
 138   let ud = getUserData bh
 139   bh <- return $! setUserData bh ud{ud_symtab = symtab}
 140   iface <- get bh
 141   return (nc', iface)
 142
 143
 144 writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
 145 writeBinIface dflags hi_path mod_iface = do
 146   bh <- openBinMem initBinMemSize
 147   put_ bh binaryInterfaceMagic
 148
 149         -- Remember where the dictionary pointer will go
 150   dict_p_p <- tellBin bh
 151   put_ bh dict_p_p      -- Placeholder for ptr to dictionary
 152
 153         -- The version and way descriptor go next
 154   put_ bh (show opt_HiVersion)
 155   way_descr <- getWayDescr
 156   put  bh way_descr
 157
 158         -- Remember where the symbol table pointer will go
 159   symtab_p_p <- tellBin bh
 160   put_ bh symtab_p_p
 161
 162         -- Make some intial state
 163   ud <- newWriteState
 164
 165         -- Put the main thing,
 166   bh <- return $ setUserData bh ud
 167   put_ bh mod_iface
 168
 169         -- Write the symtab pointer at the fornt of the file
 170   symtab_p <- tellBin bh                -- This is where the symtab will start
 171   putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
 172   seekBin bh symtab_p           -- Seek back to the end of the file
 173
 174         -- Write the symbol table itself
 175   symtab_next <- readFastMutInt (ud_symtab_next ud)
 176   symtab_map  <- readIORef (ud_symtab_map  ud)
 177   putSymbolTable bh symtab_next symtab_map
 178   debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
 179                                 <+> text "Names")
 180
 181         -- NB. write the dictionary after the symbol table, because
 182         -- writing the symbol table may create more dictionary entries.
 183
 184         -- Write the dictionary pointer at the fornt of the file
 185   dict_p <- tellBin bh          -- This is where the dictionary will start
 186   putAt bh dict_p_p dict_p      -- Fill in the placeholder
 187   seekBin bh dict_p             -- Seek back to the end of the file
 188
 189         -- Write the dictionary itself
 190   dict_next <- readFastMutInt (ud_dict_next ud)
 191   dict_map  <- readIORef (ud_dict_map  ud)
 192   putDictionary bh dict_next dict_map
 193   debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
 194                                  <+> text "dict entries")
 195
 196         -- And send the result to the file
 197   writeBinMem bh hi_path
 198
 199 initBinMemSize       = (1024*1024) :: Int
 200
 201 -- The *host* architecture version:
 202 #include "MachDeps.h"
 203
 204 #if   WORD_SIZE_IN_BITS == 32
 205 binaryInterfaceMagic = 0x1face :: Word32
 206 #elif WORD_SIZE_IN_BITS == 64
 207 binaryInterfaceMagic = 0x1face64 :: Word32
 208 #endif
 209
 210 -- -----------------------------------------------------------------------------
 211 -- The symbol table
 212
 213 putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
 214 putSymbolTable bh next_off symtab = do
 215   put_ bh next_off
 216   let names = elems (array (0,next_off-1) (eltsUFM symtab))
 217   mapM_ (\n -> serialiseName bh n symtab) names
 218
 219 getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name)
 220 getSymbolTable bh namecache = do
 221   sz <- get bh
 222   od_names <- sequence (replicate sz (get bh))
 223   let
 224         arr = listArray (0,sz-1) names
 225         (namecache', names) =
 226                 mapAccumR (fromOnDiskName arr) namecache od_names
 227   --
 228   return (namecache', arr)
 229
 230 type OnDiskName = (PackageId, ModuleName, OccName)
 231
 232 fromOnDiskName
 233    :: Array Int Name
 234    -> NameCache
 235    -> OnDiskName
 236    -> (NameCache, Name)
 237 fromOnDiskName arr nc (pid, mod_name, occ) =
 238   let
 239         mod   = mkModule pid mod_name
 240         cache = nsNames nc
 241   in
 242   case lookupOrigNameCache cache  mod occ of
 243      Just name -> (nc, name)
 244      Nothing   ->
 245         let
 246                 us        = nsUniqs nc
 247                 uniq      = uniqFromSupply us
 248                 name      = mkExternalName uniq mod occ noSrcSpan
 249                 new_cache = extendNameCache cache mod occ name
 250         in
 251         case splitUniqSupply us of { (us',_) ->
 252         ( nc{ nsUniqs = us', nsNames = new_cache }, name )
 253         }
 254
 255 serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
 256 serialiseName bh name symtab = do
 257   let mod = nameModule name
 258   put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
 259
 260 -- -----------------------------------------------------------------------------
 261 -- All the binary instances
 262
 263 -- BasicTypes
 264 {-! for IPName derive: Binary !-}
 265 {-! for Fixity derive: Binary !-}
 266 {-! for FixityDirection derive: Binary !-}
 267 {-! for Boxity derive: Binary !-}
 268 {-! for StrictnessMark derive: Binary !-}
 269 {-! for Activation derive: Binary !-}
 270
 271 -- NewDemand
 272 {-! for Demand derive: Binary !-}
 273 {-! for Demands derive: Binary !-}
 274 {-! for DmdResult derive: Binary !-}
 275 {-! for StrictSig derive: Binary !-}
 276
 277 -- Class
 278 {-! for DefMeth derive: Binary !-}
 279
 280 -- HsTypes
 281 {-! for HsPred derive: Binary !-}
 282 {-! for HsType derive: Binary !-}
 283 {-! for TupCon derive: Binary !-}
 284 {-! for HsTyVarBndr derive: Binary !-}
 285
 286 -- HsCore
 287 {-! for UfExpr derive: Binary !-}
 288 {-! for UfConAlt derive: Binary !-}
 289 {-! for UfBinding derive: Binary !-}
 290 {-! for UfBinder derive: Binary !-}
 291 {-! for HsIdInfo derive: Binary !-}
 292 {-! for UfNote derive: Binary !-}
 293
 294 -- HsDecls
 295 {-! for ConDetails derive: Binary !-}
 296 {-! for BangType derive: Binary !-}
 297
 298 -- CostCentre
 299 {-! for IsCafCC derive: Binary !-}
 300 {-! for IsDupdCC derive: Binary !-}
 301 {-! for CostCentre derive: Binary !-}
 302
 303
 304
 305 -- ---------------------------------------------------------------------------
 306 -- Reading a binary interface into ParsedIface
 307
 308 instance Binary ModIface where
 309    put_ bh (ModIface {
 310                  mi_module    = mod,
 311                  mi_boot      = is_boot,
 312                  mi_mod_vers  = mod_vers,
 313                  mi_orphan    = orphan,
 314                  mi_finsts    = hasFamInsts,
 315                  mi_deps      = deps,
 316                  mi_usages    = usages,
 317                  mi_exports   = exports,
 318                  mi_exp_vers  = exp_vers,
 319                  mi_fixities  = fixities,
 320                  mi_deprecs   = deprecs,
 321                  mi_decls     = decls,
 322                  mi_insts     = insts,
 323                  mi_fam_insts = fam_insts,
 324                  mi_rules     = rules,
 325                  mi_rule_vers = rule_vers,
 326                  mi_vect_info = vect_info,
 327                  mi_hpc       = hpc_info }) = do
 328         put_ bh mod
 329         put_ bh is_boot
 330         put_ bh mod_vers
 331         put_ bh orphan
 332         put_ bh hasFamInsts
 333         lazyPut bh deps
 334         lazyPut bh usages
 335         put_ bh exports
 336         put_ bh exp_vers
 337         put_ bh fixities
 338         lazyPut bh deprecs
 339         put_ bh decls
 340         put_ bh insts
 341         put_ bh fam_insts
 342         lazyPut bh rules
 343         put_ bh rule_vers
 344         put_ bh vect_info
 345         put_ bh hpc_info
 346
 347    get bh = do
 348         mod_name  <- get bh
 349         is_boot   <- get bh
 350         mod_vers  <- get bh
 351         orphan    <- get bh
 352         hasFamInsts <- get bh
 353         deps      <- lazyGet bh
 354         usages    <- {-# SCC "bin_usages" #-} lazyGet bh
 355         exports   <- {-# SCC "bin_exports" #-} get bh
 356         exp_vers  <- get bh
 357         fixities  <- {-# SCC "bin_fixities" #-} get bh
 358         deprecs   <- {-# SCC "bin_deprecs" #-} lazyGet bh
 359         decls     <- {-# SCC "bin_tycldecls" #-} get bh
 360         insts     <- {-# SCC "bin_insts" #-} get bh
 361         fam_insts <- {-# SCC "bin_fam_insts" #-} get bh
 362         rules     <- {-# SCC "bin_rules" #-} lazyGet bh
 363         rule_vers <- get bh
 364         vect_info <- get bh
 365         hpc_info  <- get bh
 366         return (ModIface {
 367                  mi_module    = mod_name,
 368                  mi_boot      = is_boot,
 369                  mi_mod_vers  = mod_vers,
 370                  mi_orphan    = orphan,
 371                  mi_finsts    = hasFamInsts,
 372                  mi_deps      = deps,
 373                  mi_usages    = usages,
 374                  mi_exports   = exports,
 375                  mi_exp_vers  = exp_vers,
 376                  mi_fixities  = fixities,
 377                  mi_deprecs   = deprecs,
 378                  mi_decls     = decls,
 379                  mi_globals   = Nothing,
 380                  mi_insts     = insts,
 381                  mi_fam_insts = fam_insts,
 382                  mi_rules     = rules,
 383                  mi_rule_vers = rule_vers,
 384                  mi_vect_info = vect_info,
 385                  mi_hpc       = hpc_info,
 386                         -- And build the cached values
 387                  mi_dep_fn    = mkIfaceDepCache deprecs,
 388                  mi_fix_fn    = mkIfaceFixCache fixities,
 389                  mi_ver_fn    = mkIfaceVerCache decls })
 390
 391 getWayDescr :: IO String
 392 getWayDescr = do
 393   tag <- readIORef v_Build_tag
 394   if cGhcUnregisterised == "YES" then return ('u':tag) else return tag
 395         -- if this is an unregisterised build, make sure our interfaces
 396         -- can't be used by a registerised build.
 397
 398 -------------------------------------------------------------------------
 399 --              Types from: HscTypes
 400 -------------------------------------------------------------------------
 401
 402 instance Binary Dependencies where
 403     put_ bh deps = do put_ bh (dep_mods deps)
 404                       put_ bh (dep_pkgs deps)
 405                       put_ bh (dep_orphs deps)
 406                       put_ bh (dep_finsts deps)
 407
 408     get bh = do ms <- get bh
 409                 ps <- get bh
 410                 os <- get bh
 411                 fis <- get bh
 412                 return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
 413                                dep_finsts = fis })
 414
 415 instance (Binary name) => Binary (GenAvailInfo name) where
 416     put_ bh (Avail aa) = do
 417             putByte bh 0
 418             put_ bh aa
 419     put_ bh (AvailTC ab ac) = do
 420             putByte bh 1
 421             put_ bh ab
 422             put_ bh ac
 423     get bh = do
 424             h <- getByte bh
 425             case h of
 426               0 -> do aa <- get bh
 427                       return (Avail aa)
 428               _ -> do ab <- get bh
 429                       ac <- get bh
 430                       return (AvailTC ab ac)
 431
 432 instance Binary Usage where
 433     put_ bh usg = do
 434         put_ bh (usg_name     usg)
 435         put_ bh (usg_mod      usg)
 436         put_ bh (usg_exports  usg)
 437         put_ bh (usg_entities usg)
 438         put_ bh (usg_rules    usg)
 439
 440     get bh = do
 441         nm    <- get bh
 442         mod   <- get bh
 443         exps  <- get bh
 444         ents  <- get bh
 445         rules <- get bh
 446         return (Usage { usg_name = nm, usg_mod = mod,
 447                         usg_exports = exps, usg_entities = ents,
 448                         usg_rules = rules })
 449
 450 instance Binary Deprecations where
 451     put_ bh NoDeprecs     = putByte bh 0
 452     put_ bh (DeprecAll t) = do
 453             putByte bh 1
 454             put_ bh t
 455     put_ bh (DeprecSome ts) = do
 456             putByte bh 2
 457             put_ bh ts
 458
 459     get bh = do
 460             h <- getByte bh
 461             case h of
 462               0 -> return NoDeprecs
 463               1 -> do aa <- get bh
 464                       return (DeprecAll aa)
 465               _ -> do aa <- get bh
 466                       return (DeprecSome aa)
 467
 468 -------------------------------------------------------------------------
 469 --              Types from: BasicTypes
 470 -------------------------------------------------------------------------
 471
 472 instance Binary Activation where
 473     put_ bh NeverActive = do
 474             putByte bh 0
 475     put_ bh AlwaysActive = do
 476             putByte bh 1
 477     put_ bh (ActiveBefore aa) = do
 478             putByte bh 2
 479             put_ bh aa
 480     put_ bh (ActiveAfter ab) = do
 481             putByte bh 3
 482             put_ bh ab
 483     get bh = do
 484             h <- getByte bh
 485             case h of
 486               0 -> do return NeverActive
 487               1 -> do return AlwaysActive
 488               2 -> do aa <- get bh
 489                       return (ActiveBefore aa)
 490               _ -> do ab <- get bh
 491                       return (ActiveAfter ab)
 492
 493 instance Binary StrictnessMark where
 494     put_ bh MarkedStrict = do
 495             putByte bh 0
 496     put_ bh MarkedUnboxed = do
 497             putByte bh 1
 498     put_ bh NotMarkedStrict = do
 499             putByte bh 2
 500     get bh = do
 501             h <- getByte bh
 502             case h of
 503               0 -> do return MarkedStrict
 504               1 -> do return MarkedUnboxed
 505               _ -> do return NotMarkedStrict
 506
 507 instance Binary Boxity where
 508     put_ bh Boxed = do
 509             putByte bh 0
 510     put_ bh Unboxed = do
 511             putByte bh 1
 512     get bh = do
 513             h <- getByte bh
 514             case h of
 515               0 -> do return Boxed
 516               _ -> do return Unboxed
 517
 518 instance Binary TupCon where
 519     put_ bh (TupCon ab ac) = do
 520             put_ bh ab
 521             put_ bh ac
 522     get bh = do
 523           ab <- get bh
 524           ac <- get bh
 525           return (TupCon ab ac)
 526
 527 instance Binary RecFlag where
 528     put_ bh Recursive = do
 529             putByte bh 0
 530     put_ bh NonRecursive = do
 531             putByte bh 1
 532     get bh = do
 533             h <- getByte bh
 534             case h of
 535               0 -> do return Recursive
 536               _ -> do return NonRecursive
 537
 538 instance Binary DefMeth where
 539     put_ bh NoDefMeth  = putByte bh 0
 540     put_ bh DefMeth    = putByte bh 1
 541     put_ bh GenDefMeth = putByte bh 2
 542     get bh = do
 543             h <- getByte bh
 544             case h of
 545               0 -> return NoDefMeth
 546               1 -> return DefMeth
 547               _ -> return GenDefMeth
 548
 549 instance Binary FixityDirection where
 550     put_ bh InfixL = do
 551             putByte bh 0
 552     put_ bh InfixR = do
 553             putByte bh 1
 554     put_ bh InfixN = do
 555             putByte bh 2
 556     get bh = do
 557             h <- getByte bh
 558             case h of
 559               0 -> do return InfixL
 560               1 -> do return InfixR
 561               _ -> do return InfixN
 562
 563 instance Binary Fixity where
 564     put_ bh (Fixity aa ab) = do
 565             put_ bh aa
 566             put_ bh ab
 567     get bh = do
 568           aa <- get bh
 569           ab <- get bh
 570           return (Fixity aa ab)
 571
 572 instance (Binary name) => Binary (IPName name) where
 573     put_ bh (IPName aa) = put_ bh aa
 574     get bh = do aa <- get bh
 575                 return (IPName aa)
 576
 577 -------------------------------------------------------------------------
 578 --              Types from: Demand
 579 -------------------------------------------------------------------------
 580
 581 instance Binary DmdType where
 582         -- Ignore DmdEnv when spitting out the DmdType
 583   put bh (DmdType _ ds dr) = do p <- put bh ds; put bh dr; return (castBin p)
 584   get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
 585
 586 instance Binary Demand where
 587     put_ bh Top = do
 588             putByte bh 0
 589     put_ bh Abs = do
 590             putByte bh 1
 591     put_ bh (Call aa) = do
 592             putByte bh 2
 593             put_ bh aa
 594     put_ bh (Eval ab) = do
 595             putByte bh 3
 596             put_ bh ab
 597     put_ bh (Defer ac) = do
 598             putByte bh 4
 599             put_ bh ac
 600     put_ bh (Box ad) = do
 601             putByte bh 5
 602             put_ bh ad
 603     put_ bh Bot = do
 604             putByte bh 6
 605     get bh = do
 606             h <- getByte bh
 607             case h of
 608               0 -> do return Top
 609               1 -> do return Abs
 610               2 -> do aa <- get bh
 611                       return (Call aa)
 612               3 -> do ab <- get bh
 613                       return (Eval ab)
 614               4 -> do ac <- get bh
 615                       return (Defer ac)
 616               5 -> do ad <- get bh
 617                       return (Box ad)
 618               _ -> do return Bot
 619
 620 instance Binary Demands where
 621     put_ bh (Poly aa) = do
 622             putByte bh 0
 623             put_ bh aa
 624     put_ bh (Prod ab) = do
 625             putByte bh 1
 626             put_ bh ab
 627     get bh = do
 628             h <- getByte bh
 629             case h of
 630               0 -> do aa <- get bh
 631                       return (Poly aa)
 632               _ -> do ab <- get bh
 633                       return (Prod ab)
 634
 635 instance Binary DmdResult where
 636     put_ bh TopRes = do
 637             putByte bh 0
 638     put_ bh RetCPR = do
 639             putByte bh 1
 640     put_ bh BotRes = do
 641             putByte bh 2
 642     get bh = do
 643             h <- getByte bh
 644             case h of
 645               0 -> do return TopRes
 646               1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
 647                                         -- The wrapper was generated for CPR in
 648                                         -- the imported module!
 649               _ -> do return BotRes
 650
 651 instance Binary StrictSig where
 652     put_ bh (StrictSig aa) = do
 653             put_ bh aa
 654     get bh = do
 655           aa <- get bh
 656           return (StrictSig aa)
 657
 658
 659 -------------------------------------------------------------------------
 660 --              Types from: CostCentre
 661 -------------------------------------------------------------------------
 662
 663 instance Binary IsCafCC where
 664     put_ bh CafCC = do
 665             putByte bh 0
 666     put_ bh NotCafCC = do
 667             putByte bh 1
 668     get bh = do
 669             h <- getByte bh
 670             case h of
 671               0 -> do return CafCC
 672               _ -> do return NotCafCC
 673
 674 instance Binary IsDupdCC where
 675     put_ bh OriginalCC = do
 676             putByte bh 0
 677     put_ bh DupdCC = do
 678             putByte bh 1
 679     get bh = do
 680             h <- getByte bh
 681             case h of
 682               0 -> do return OriginalCC
 683               _ -> do return DupdCC
 684
 685 instance Binary CostCentre where
 686     put_ bh NoCostCentre = do
 687             putByte bh 0
 688     put_ bh (NormalCC aa ab ac ad) = do
 689             putByte bh 1
 690             put_ bh aa
 691             put_ bh ab
 692             put_ bh ac
 693             put_ bh ad
 694     put_ bh (AllCafsCC ae) = do
 695             putByte bh 2
 696             put_ bh ae
 697     get bh = do
 698             h <- getByte bh
 699             case h of
 700               0 -> do return NoCostCentre
 701               1 -> do aa <- get bh
 702                       ab <- get bh
 703                       ac <- get bh
 704                       ad <- get bh
 705                       return (NormalCC aa ab ac ad)
 706               _ -> do ae <- get bh
 707                       return (AllCafsCC ae)
 708
 709 -------------------------------------------------------------------------
 710 --              IfaceTypes and friends
 711 -------------------------------------------------------------------------
 712
 713 instance Binary IfaceBndr where
 714     put_ bh (IfaceIdBndr aa) = do
 715             putByte bh 0
 716             put_ bh aa
 717     put_ bh (IfaceTvBndr ab) = do
 718             putByte bh 1
 719             put_ bh ab
 720     get bh = do
 721             h <- getByte bh
 722             case h of
 723               0 -> do aa <- get bh
 724                       return (IfaceIdBndr aa)
 725               _ -> do ab <- get bh
 726                       return (IfaceTvBndr ab)
 727
 728 instance Binary IfaceLetBndr where
 729     put_ bh (IfLetBndr a b c) = do
 730             put_ bh a
 731             put_ bh b
 732             put_ bh c
 733     get bh = do a <- get bh
 734                 b <- get bh
 735                 c <- get bh
 736                 return (IfLetBndr a b c)
 737
 738 instance Binary IfaceType where
 739     put_ bh (IfaceForAllTy aa ab) = do
 740             putByte bh 0
 741             put_ bh aa
 742             put_ bh ab
 743     put_ bh (IfaceTyVar ad) = do
 744             putByte bh 1
 745             put_ bh ad
 746     put_ bh (IfaceAppTy ae af) = do
 747             putByte bh 2
 748             put_ bh ae
 749             put_ bh af
 750     put_ bh (IfaceFunTy ag ah) = do
 751             putByte bh 3
 752             put_ bh ag
 753             put_ bh ah
 754     put_ bh (IfacePredTy aq) = do
 755             putByte bh 5
 756             put_ bh aq
 757
 758         -- Simple compression for common cases of TyConApp
 759     put_ bh (IfaceTyConApp IfaceIntTc  [])   = putByte bh 6
 760     put_ bh (IfaceTyConApp IfaceCharTc [])   = putByte bh 7
 761     put_ bh (IfaceTyConApp IfaceBoolTc [])   = putByte bh 8
 762     put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
 763         -- Unit tuple and pairs
 764     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 0) [])      = putByte bh 10
 765     put_ bh (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
 766         -- Kind cases
 767     put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc [])   = putByte bh 12
 768     put_ bh (IfaceTyConApp IfaceOpenTypeKindTc [])     = putByte bh 13
 769     put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
 770     put_ bh (IfaceTyConApp IfaceUbxTupleKindTc [])     = putByte bh 15
 771     put_ bh (IfaceTyConApp IfaceArgTypeKindTc [])      = putByte bh 16
 772
 773         -- Generic cases
 774
 775     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
 776     put_ bh (IfaceTyConApp tc tys)           = do { putByte bh 19; put_ bh tc; put_ bh tys }
 777
 778     get bh = do
 779             h <- getByte bh
 780             case h of
 781               0 -> do aa <- get bh
 782                       ab <- get bh
 783                       return (IfaceForAllTy aa ab)
 784               1 -> do ad <- get bh
 785                       return (IfaceTyVar ad)
 786               2 -> do ae <- get bh
 787                       af <- get bh
 788                       return (IfaceAppTy ae af)
 789               3 -> do ag <- get bh
 790                       ah <- get bh
 791                       return (IfaceFunTy ag ah)
 792               5 -> do ap <- get bh
 793                       return (IfacePredTy ap)
 794
 795                 -- Now the special cases for TyConApp
 796               6 -> return (IfaceTyConApp IfaceIntTc [])
 797               7 -> return (IfaceTyConApp IfaceCharTc [])
 798               8 -> return (IfaceTyConApp IfaceBoolTc [])
 799               9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
 800               10 -> return (IfaceTyConApp (IfaceTupTc Boxed 0) [])
 801               11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc Boxed 2) [t1,t2]) }
 802               12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
 803               13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
 804               14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
 805               15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
 806               16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
 807
 808               18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
 809               _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
 810
 811 instance Binary IfaceTyCon where
 812         -- Int,Char,Bool can't show up here because they can't not be saturated
 813
 814    put_ bh IfaceIntTc         = putByte bh 1
 815    put_ bh IfaceBoolTc        = putByte bh 2
 816    put_ bh IfaceCharTc        = putByte bh 3
 817    put_ bh IfaceListTc        = putByte bh 4
 818    put_ bh IfacePArrTc        = putByte bh 5
 819    put_ bh IfaceLiftedTypeKindTc   = putByte bh 6
 820    put_ bh IfaceOpenTypeKindTc     = putByte bh 7
 821    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
 822    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
 823    put_ bh IfaceArgTypeKindTc      = putByte bh 10
 824    put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
 825    put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
 826
 827    get bh = do
 828         h <- getByte bh
 829         case h of
 830           1 -> return IfaceIntTc
 831           2 -> return IfaceBoolTc
 832           3 -> return IfaceCharTc
 833           4 -> return IfaceListTc
 834           5 -> return IfacePArrTc
 835           6 -> return IfaceLiftedTypeKindTc
 836           7 -> return IfaceOpenTypeKindTc
 837           8 -> return IfaceUnliftedTypeKindTc
 838           9 -> return IfaceUbxTupleKindTc
 839           10 -> return IfaceArgTypeKindTc
 840           11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
 841           _ -> do { ext <- get bh; return (IfaceTc ext) }
 842
 843 instance Binary IfacePredType where
 844     put_ bh (IfaceClassP aa ab) = do
 845             putByte bh 0
 846             put_ bh aa
 847             put_ bh ab
 848     put_ bh (IfaceIParam ac ad) = do
 849             putByte bh 1
 850             put_ bh ac
 851             put_ bh ad
 852     put_ bh (IfaceEqPred ac ad) = do
 853             putByte bh 2
 854             put_ bh ac
 855             put_ bh ad
 856     get bh = do
 857             h <- getByte bh
 858             case h of
 859               0 -> do aa <- get bh
 860                       ab <- get bh
 861                       return (IfaceClassP aa ab)
 862               1 -> do ac <- get bh
 863                       ad <- get bh
 864                       return (IfaceIParam ac ad)
 865               2 -> do ac <- get bh
 866                       ad <- get bh
 867                       return (IfaceEqPred ac ad)
 868
 869 -------------------------------------------------------------------------
 870 --              IfaceExpr and friends
 871 -------------------------------------------------------------------------
 872
 873 instance Binary IfaceExpr where
 874     put_ bh (IfaceLcl aa) = do
 875             putByte bh 0
 876             put_ bh aa
 877     put_ bh (IfaceType ab) = do
 878             putByte bh 1
 879             put_ bh ab
 880     put_ bh (IfaceTuple ac ad) = do
 881             putByte bh 2
 882             put_ bh ac
 883             put_ bh ad
 884     put_ bh (IfaceLam ae af) = do
 885             putByte bh 3
 886             put_ bh ae
 887             put_ bh af
 888     put_ bh (IfaceApp ag ah) = do
 889             putByte bh 4
 890             put_ bh ag
 891             put_ bh ah
 892 -- gaw 2004
 893     put_ bh (IfaceCase ai aj al ak) = do
 894             putByte bh 5
 895             put_ bh ai
 896             put_ bh aj
 897 -- gaw 2004
 898             put_ bh al
 899             put_ bh ak
 900     put_ bh (IfaceLet al am) = do
 901             putByte bh 6
 902             put_ bh al
 903             put_ bh am
 904     put_ bh (IfaceNote an ao) = do
 905             putByte bh 7
 906             put_ bh an
 907             put_ bh ao
 908     put_ bh (IfaceLit ap) = do
 909             putByte bh 8
 910             put_ bh ap
 911     put_ bh (IfaceFCall as at) = do
 912             putByte bh 9
 913             put_ bh as
 914             put_ bh at
 915     put_ bh (IfaceExt aa) = do
 916             putByte bh 10
 917             put_ bh aa
 918     put_ bh (IfaceCast ie ico) = do
 919             putByte bh 11
 920             put_ bh ie
 921             put_ bh ico
 922     put_ bh (IfaceTick m ix) = do
 923             putByte bh 12
 924             put_ bh m
 925             put_ bh ix
 926     get bh = do
 927             h <- getByte bh
 928             case h of
 929               0 -> do aa <- get bh
 930                       return (IfaceLcl aa)
 931               1 -> do ab <- get bh
 932                       return (IfaceType ab)
 933               2 -> do ac <- get bh
 934                       ad <- get bh
 935                       return (IfaceTuple ac ad)
 936               3 -> do ae <- get bh
 937                       af <- get bh
 938                       return (IfaceLam ae af)
 939               4 -> do ag <- get bh
 940                       ah <- get bh
 941                       return (IfaceApp ag ah)
 942               5 -> do ai <- get bh
 943                       aj <- get bh
 944 -- gaw 2004
 945                       al <- get bh
 946                       ak <- get bh
 947 -- gaw 2004
 948                       return (IfaceCase ai aj al ak)
 949               6 -> do al <- get bh
 950                       am <- get bh
 951                       return (IfaceLet al am)
 952               7 -> do an <- get bh
 953                       ao <- get bh
 954                       return (IfaceNote an ao)
 955               8 -> do ap <- get bh
 956                       return (IfaceLit ap)
 957               9 -> do as <- get bh
 958                       at <- get bh
 959                       return (IfaceFCall as at)
 960               10 -> do aa <- get bh
 961                        return (IfaceExt aa)
 962               11 -> do ie <- get bh
 963                        ico <- get bh
 964                        return (IfaceCast ie ico)
 965               12 -> do m <- get bh
 966                        ix <- get bh
 967                        return (IfaceTick m ix)
 968
 969 instance Binary IfaceConAlt where
 970     put_ bh IfaceDefault = do
 971             putByte bh 0
 972     put_ bh (IfaceDataAlt aa) = do
 973             putByte bh 1
 974             put_ bh aa
 975     put_ bh (IfaceTupleAlt ab) = do
 976             putByte bh 2
 977             put_ bh ab
 978     put_ bh (IfaceLitAlt ac) = do
 979             putByte bh 3
 980             put_ bh ac
 981     get bh = do
 982             h <- getByte bh
 983             case h of
 984               0 -> do return IfaceDefault
 985               1 -> do aa <- get bh
 986                       return (IfaceDataAlt aa)
 987               2 -> do ab <- get bh
 988                       return (IfaceTupleAlt ab)
 989               _ -> do ac <- get bh
 990                       return (IfaceLitAlt ac)
 991
 992 instance Binary IfaceBinding where
 993     put_ bh (IfaceNonRec aa ab) = do
 994             putByte bh 0
 995             put_ bh aa
 996             put_ bh ab
 997     put_ bh (IfaceRec ac) = do
 998             putByte bh 1
 999             put_ bh ac
1000     get bh = do
1001             h <- getByte bh
1002             case h of
1003               0 -> do aa <- get bh
1004                       ab <- get bh
1005                       return (IfaceNonRec aa ab)
1006               _ -> do ac <- get bh
1007                       return (IfaceRec ac)
1008
1009 instance Binary IfaceIdInfo where
1010     put_ bh NoInfo = putByte bh 0
1011     put_ bh (HasInfo i) = do
1012             putByte bh 1
1013             lazyPut bh i                        -- NB lazyPut
1014
1015     get bh = do
1016             h <- getByte bh
1017             case h of
1018               0 -> return NoInfo
1019               _ -> do info <- lazyGet bh        -- NB lazyGet
1020                       return (HasInfo info)
1021
1022 instance Binary IfaceInfoItem where
1023     put_ bh (HsArity aa) = do
1024             putByte bh 0
1025             put_ bh aa
1026     put_ bh (HsStrictness ab) = do
1027             putByte bh 1
1028             put_ bh ab
1029     put_ bh (HsUnfold ad) = do
1030             putByte bh 2
1031             put_ bh ad
1032     put_ bh (HsInline ad) = do
1033             putByte bh 3
1034             put_ bh ad
1035     put_ bh HsNoCafRefs = do
1036             putByte bh 4
1037     put_ bh (HsWorker ae af) = do
1038             putByte bh 5
1039             put_ bh ae
1040             put_ bh af
1041     get bh = do
1042             h <- getByte bh
1043             case h of
1044               0 -> do aa <- get bh
1045                       return (HsArity aa)
1046               1 -> do ab <- get bh
1047                       return (HsStrictness ab)
1048               2 -> do ad <- get bh
1049                       return (HsUnfold ad)
1050               3 -> do ad <- get bh
1051                       return (HsInline ad)
1052               4 -> do return HsNoCafRefs
1053               _ -> do ae <- get bh
1054                       af <- get bh
1055                       return (HsWorker ae af)
1056
1057 instance Binary IfaceNote where
1058     put_ bh (IfaceSCC aa) = do
1059             putByte bh 0
1060             put_ bh aa
1061     put_ bh IfaceInlineMe = do
1062             putByte bh 3
1063     put_ bh (IfaceCoreNote s) = do
1064             putByte bh 4
1065             put_ bh s
1066     get bh = do
1067             h <- getByte bh
1068             case h of
1069               0 -> do aa <- get bh
1070                       return (IfaceSCC aa)
1071               3 -> do return IfaceInlineMe
1072               4 -> do ac <- get bh
1073                       return (IfaceCoreNote ac)
1074
1075 -------------------------------------------------------------------------
1076 --              IfaceDecl and friends
1077 -------------------------------------------------------------------------
1078
1079 -- A bit of magic going on here: there's no need to store the OccName
1080 -- for a decl on the disk, since we can infer the namespace from the
1081 -- context; however it is useful to have the OccName in the IfaceDecl
1082 -- to avoid re-building it in various places.  So we build the OccName
1083 -- when de-serialising.
1084
1085 instance Binary IfaceDecl where
1086     put_ bh (IfaceId name ty idinfo) = do
1087             putByte bh 0
1088             put_ bh (occNameFS name)
1089             put_ bh ty
1090             put_ bh idinfo
1091     put_ bh (IfaceForeign ae af) =
1092         error "Binary.put_(IfaceDecl): IfaceForeign"
1093     put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1094             putByte bh 2
1095             put_ bh (occNameFS a1)
1096             put_ bh a2
1097             put_ bh a3
1098             put_ bh a4
1099             put_ bh a5
1100             put_ bh a6
1101             put_ bh a7
1102             put_ bh a8
1103     put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do
1104             putByte bh 3
1105             put_ bh (occNameFS a1)
1106             put_ bh a2
1107             put_ bh a3
1108             put_ bh a4
1109             put_ bh a5
1110     put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1111             putByte bh 4
1112             put_ bh a1
1113             put_ bh (occNameFS a2)
1114             put_ bh a3
1115             put_ bh a4
1116             put_ bh a5
1117             put_ bh a6
1118             put_ bh a7
1119     get bh = do
1120             h <- getByte bh
1121             case h of
1122               0 -> do name   <- get bh
1123                       ty     <- get bh
1124                       idinfo <- get bh
1125                       occ <- return $! mkOccNameFS varName name
1126                       return (IfaceId occ ty idinfo)
1127               1 -> error "Binary.get(TyClDecl): ForeignType"
1128               2 -> do
1129                     a1 <- get bh
1130                     a2 <- get bh
1131                     a3 <- get bh
1132                     a4 <- get bh
1133                     a5 <- get bh
1134                     a6 <- get bh
1135                     a7 <- get bh
1136                     a8 <- get bh
1137                     occ <- return $! mkOccNameFS tcName a1
1138                     return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1139               3 -> do
1140                     a1 <- get bh
1141                     a2 <- get bh
1142                     a3 <- get bh
1143                     a4 <- get bh
1144                     a5 <- get bh
1145                     occ <- return $! mkOccNameFS tcName a1
1146                     return (IfaceSyn occ a2 a3 a4 a5)
1147               _ -> do
1148                     a1 <- get bh
1149                     a2 <- get bh
1150                     a3 <- get bh
1151                     a4 <- get bh
1152                     a5 <- get bh
1153                     a6 <- get bh
1154                     a7 <- get bh
1155                     occ <- return $! mkOccNameFS clsName a2
1156                     return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1157
1158 instance Binary IfaceInst where
1159     put_ bh (IfaceInst cls tys dfun flag orph) = do
1160             put_ bh cls
1161             put_ bh tys
1162             put_ bh dfun
1163             put_ bh flag
1164             put_ bh orph
1165     get bh = do cls  <- get bh
1166                 tys  <- get bh
1167                 dfun <- get bh
1168                 flag <- get bh
1169                 orph <- get bh
1170                 return (IfaceInst cls tys dfun flag orph)
1171
1172 instance Binary IfaceFamInst where
1173     put_ bh (IfaceFamInst fam tys tycon) = do
1174             put_ bh fam
1175             put_ bh tys
1176             put_ bh tycon
1177     get bh = do fam   <- get bh
1178                 tys   <- get bh
1179                 tycon <- get bh
1180                 return (IfaceFamInst fam tys tycon)
1181
1182 instance Binary OverlapFlag where
1183     put_ bh NoOverlap  = putByte bh 0
1184     put_ bh OverlapOk  = putByte bh 1
1185     put_ bh Incoherent = putByte bh 2
1186     get bh = do h <- getByte bh
1187                 case h of
1188                   0 -> return NoOverlap
1189                   1 -> return OverlapOk
1190                   2 -> return Incoherent
1191
1192 instance Binary IfaceConDecls where
1193     put_ bh IfAbstractTyCon = putByte bh 0
1194     put_ bh IfOpenDataTyCon = putByte bh 1
1195     put_ bh (IfDataTyCon cs) = do { putByte bh 2
1196                                   ; put_ bh cs }
1197     put_ bh (IfNewTyCon c)  = do { putByte bh 3
1198                                   ; put_ bh c }
1199     get bh = do
1200             h <- getByte bh
1201             case h of
1202               0 -> return IfAbstractTyCon
1203               1 -> return IfOpenDataTyCon
1204               2 -> do cs <- get bh
1205                       return (IfDataTyCon cs)
1206               _ -> do aa <- get bh
1207                       return (IfNewTyCon aa)
1208
1209 instance Binary IfaceConDecl where
1210     put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9) = do
1211             put_ bh a1
1212             put_ bh a2
1213             put_ bh a3
1214             put_ bh a4
1215             put_ bh a5
1216             put_ bh a6
1217             put_ bh a7
1218             put_ bh a8
1219             put_ bh a9
1220     get bh = do a1 <- get bh
1221                 a2 <- get bh
1222                 a3 <- get bh
1223                 a4 <- get bh
1224                 a5 <- get bh
1225                 a6 <- get bh
1226                 a7 <- get bh
1227                 a8 <- get bh
1228                 a9 <- get bh
1229                 return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9)
1230
1231 instance Binary IfaceClassOp where
1232    put_ bh (IfaceClassOp n def ty) = do
1233         put_ bh (occNameFS n)
1234         put_ bh def
1235         put_ bh ty
1236    get bh = do
1237         n <- get bh
1238         def <- get bh
1239         ty <- get bh
1240         occ <- return $! mkOccNameFS varName n
1241         return (IfaceClassOp occ def ty)
1242
1243 instance Binary IfaceRule where
1244     put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do
1245             put_ bh a1
1246             put_ bh a2
1247             put_ bh a3
1248             put_ bh a4
1249             put_ bh a5
1250             put_ bh a6
1251             put_ bh a7
1252     get bh = do
1253             a1 <- get bh
1254             a2 <- get bh
1255             a3 <- get bh
1256             a4 <- get bh
1257             a5 <- get bh
1258             a6 <- get bh
1259             a7 <- get bh
1260             return (IfaceRule a1 a2 a3 a4 a5 a6 a7)
1261
1262 instance Binary IfaceVectInfo where
1263     put_ bh (IfaceVectInfo a1 a2 a3) = do
1264             put_ bh a1
1265             put_ bh a2
1266             put_ bh a3
1267     get bh = do
1268             a1 <- get bh
1269             a2 <- get bh
1270             a3 <- get bh
1271             return (IfaceVectInfo a1 a2 a3)
1272
1273