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