compiler/iface/BinIface.hs

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