compiler/iface/BinIface.hs

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