root/compiler/iface/BinIface.hs

Revision ac230c5ef652e27f61d954281ae6a3195e1f9970, 50.2 KB (checked in by Simon Peyton Jones <simonpj@…>, 4 weeks ago)

Allow cases with empty alterantives

This patch allows, for the first time, case expressions with an empty
list of alternatives. Max suggested the idea, and Trac #6067 showed
that it is really quite important.

So I've implemented the idea, fixing #6067. Main changes

  • See Note [Empty case alternatives] in CoreSyn?
  • Various foldr1's become foldrs
  • IfaceCase? does not record the type of the alternatives. I added IfaceECase for empty-alternative cases.
  • Core Lint does not complain about empty cases
  • MkCore?.castBottomExpr constructs an empty-alternative case expression (case e of ty {})
  • Property mode set to 100644
Line 
1--
2--  (c) The University of Glasgow 2002-2006
3--
4
5{-# OPTIONS_GHC -O #-}
6-- We always optimise this, otherwise performance of a non-optimised
7-- compiler is severely affected
8
9-- | Binary interface file support.
10module BinIface (
11        writeBinIface,
12        readBinIface,
13        getSymtabName,
14        getDictFastString,
15        CheckHiWay(..),
16        TraceBinIFaceReading(..)
17    ) where
18
19#include "HsVersions.h"
20
21import TcRnMonad
22import TyCon      (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon, tyConIP_maybe)
23import DataCon    (dataConName, dataConWorkId, dataConTyCon)
24import IParam     (ipFastString, ipTyConName)
25import PrelInfo   (wiredInThings, basicKnownKeyNames)
26import Id         (idName, isDataConWorkId_maybe)
27import TysWiredIn
28import IfaceEnv
29import HscTypes
30import BasicTypes
31import Demand
32import Annotations
33import IfaceSyn
34import Module
35import Name
36import Avail
37import VarEnv
38import DynFlags
39import UniqFM
40import UniqSupply
41import CostCentre
42import StaticFlags
43import Panic
44import Binary
45import SrcLoc
46import ErrUtils
47import Config
48import FastMutInt
49import Unique
50import Outputable
51import Platform
52import FastString
53import Constants
54
55import Data.Bits
56import Data.Char
57import Data.List
58import Data.Word
59import Data.Array
60import Data.IORef
61import Control.Monad
62
63
64-- ---------------------------------------------------------------------------
65-- Reading and writing binary interface files
66--
67
68data CheckHiWay = CheckHiWay | IgnoreHiWay
69    deriving Eq
70
71data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
72    deriving Eq
73
74-- | Read an interface file
75readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
76             -> TcRnIf a b ModIface
77readBinIface checkHiWay traceBinIFaceReading hi_path = do
78    ncu <- mkNameCacheUpdater
79    dflags <- getDynFlags
80    liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
81
82readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
83              -> NameCacheUpdater
84              -> IO ModIface
85readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
86    let printer :: SDoc -> IO ()
87        printer = case traceBinIFaceReading of
88                      TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
89                      QuietBinIFaceReading -> \_ -> return ()
90        wantedGot :: Outputable a => String -> a -> a -> IO ()
91        wantedGot what wanted got =
92            printer (text what <> text ": " <>
93                     vcat [text "Wanted " <> ppr wanted <> text ",",
94                           text "got    " <> ppr got])
95
96        errorOnMismatch :: (Eq a, Show a) => String -> a -> a -> IO ()
97        errorOnMismatch what wanted got =
98            -- This will be caught by readIface which will emit an error
99            -- msg containing the iface module name.
100            when (wanted /= got) $ ghcError $ ProgramError
101                         (what ++ " (wanted " ++ show wanted
102                               ++ ", got "    ++ show got ++ ")")
103    bh <- Binary.readBinMem hi_path
104
105    -- Read the magic number to check that this really is a GHC .hi file
106    -- (This magic number does not change when we change
107    --  GHC interface file format)
108    magic <- get bh
109    wantedGot "Magic" (binaryInterfaceMagic dflags) magic
110    errorOnMismatch "magic number mismatch: old/corrupt interface file?"
111        (binaryInterfaceMagic dflags) magic
112
113    -- Note [dummy iface field]
114    -- read a dummy 32/64 bit value.  This field used to hold the
115    -- dictionary pointer in old interface file formats, but now
116    -- the dictionary pointer is after the version (where it
117    -- should be).  Also, the serialisation of value of type "Bin
118    -- a" used to depend on the word size of the machine, now they
119    -- are always 32 bits.
120    if wORD_SIZE == 4
121        then do _ <- Binary.get bh :: IO Word32; return ()
122        else do _ <- Binary.get bh :: IO Word64; return ()
123
124    -- Check the interface file version and ways.
125    check_ver  <- get bh
126    let our_ver = show opt_HiVersion
127    wantedGot "Version" our_ver check_ver
128    errorOnMismatch "mismatched interface file versions" our_ver check_ver
129
130    check_way <- get bh
131    let way_descr = getWayDescr dflags
132    wantedGot "Way" way_descr check_way
133    when (checkHiWay == CheckHiWay) $
134        errorOnMismatch "mismatched interface file ways" way_descr check_way
135
136    -- Read the dictionary
137    -- The next word in the file is a pointer to where the dictionary is
138    -- (probably at the end of the file)
139    dict_p <- Binary.get bh
140    data_p <- tellBin bh          -- Remember where we are now
141    seekBin bh dict_p
142    dict   <- getDictionary bh
143    seekBin bh data_p             -- Back to where we were before
144
145    -- Initialise the user-data field of bh
146    bh <- do
147        bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
148                                                     (getDictFastString dict)
149        symtab_p <- Binary.get bh     -- Get the symtab ptr
150        data_p <- tellBin bh          -- Remember where we are now
151        seekBin bh symtab_p
152        symtab <- getSymbolTable bh ncu
153        seekBin bh data_p             -- Back to where we were before
154   
155        -- It is only now that we know how to get a Name
156        return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
157                                               (getDictFastString dict)
158
159    -- Read the interface file
160    get bh
161
162-- | Write an interface file
163writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
164writeBinIface dflags hi_path mod_iface = do
165    bh <- openBinMem initBinMemSize
166    put_ bh (binaryInterfaceMagic dflags)
167
168   -- dummy 32/64-bit field before the version/way for
169   -- compatibility with older interface file formats.
170   -- See Note [dummy iface field] above.
171    if wORD_SIZE == 4
172        then Binary.put_ bh (0 :: Word32)
173        else Binary.put_ bh (0 :: Word64)
174
175    -- The version and way descriptor go next
176    put_ bh (show opt_HiVersion)
177    let way_descr = getWayDescr dflags
178    put_  bh way_descr
179
180    -- Remember where the dictionary pointer will go
181    dict_p_p <- tellBin bh
182    -- Placeholder for ptr to dictionary
183    put_ bh dict_p_p
184
185    -- Remember where the symbol table pointer will go
186    symtab_p_p <- tellBin bh
187    put_ bh symtab_p_p
188
189    -- Make some intial state
190    symtab_next <- newFastMutInt
191    writeFastMutInt symtab_next 0
192    symtab_map <- newIORef emptyUFM
193    let bin_symtab = BinSymbolTable {
194                         bin_symtab_next = symtab_next,
195                         bin_symtab_map  = symtab_map }
196    dict_next_ref <- newFastMutInt
197    writeFastMutInt dict_next_ref 0
198    dict_map_ref <- newIORef emptyUFM
199    let bin_dict = BinDictionary {
200                       bin_dict_next = dict_next_ref,
201                       bin_dict_map  = dict_map_ref }
202 
203    -- Put the main thing,
204    bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
205                                                  (putFastString bin_dict)
206    put_ bh mod_iface
207
208    -- Write the symtab pointer at the fornt of the file
209    symtab_p <- tellBin bh        -- This is where the symtab will start
210    putAt bh symtab_p_p symtab_p  -- Fill in the placeholder
211    seekBin bh symtab_p           -- Seek back to the end of the file
212
213    -- Write the symbol table itself
214    symtab_next <- readFastMutInt symtab_next
215    symtab_map  <- readIORef symtab_map
216    putSymbolTable bh symtab_next symtab_map
217    debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next
218                                <+> text "Names")
219
220    -- NB. write the dictionary after the symbol table, because
221    -- writing the symbol table may create more dictionary entries.
222
223    -- Write the dictionary pointer at the fornt of the file
224    dict_p <- tellBin bh          -- This is where the dictionary will start
225    putAt bh dict_p_p dict_p      -- Fill in the placeholder
226    seekBin bh dict_p             -- Seek back to the end of the file
227
228    -- Write the dictionary itself
229    dict_next <- readFastMutInt dict_next_ref
230    dict_map  <- readIORef dict_map_ref
231    putDictionary bh dict_next dict_map
232    debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next
233                                <+> text "dict entries")
234
235    -- And send the result to the file
236    writeBinMem bh hi_path
237
238-- | Initial ram buffer to allocate for writing interface files
239initBinMemSize :: Int
240initBinMemSize = 1024 * 1024
241
242binaryInterfaceMagic :: DynFlags -> Word32
243binaryInterfaceMagic dflags
244 | target32Bit (targetPlatform dflags) = 0x1face
245 | otherwise                           = 0x1face64
246
247
248-- -----------------------------------------------------------------------------
249-- The symbol table
250--
251
252putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO ()
253putSymbolTable bh next_off symtab = do
254    put_ bh next_off
255    let names = elems (array (0,next_off-1) (eltsUFM symtab))
256    mapM_ (\n -> serialiseName bh n symtab) names
257
258getSymbolTable :: BinHandle -> NameCacheUpdater -> IO SymbolTable
259getSymbolTable bh ncu = do
260    sz <- get bh
261    od_names <- sequence (replicate sz (get bh))
262    updateNameCache ncu $ \namecache ->
263        let arr = listArray (0,sz-1) names
264            (namecache', names) =   
265                mapAccumR (fromOnDiskName arr) namecache od_names
266        in (namecache', arr)
267
268type OnDiskName = (PackageId, ModuleName, OccName)
269
270fromOnDiskName :: Array Int Name -> NameCache -> OnDiskName -> (NameCache, Name)
271fromOnDiskName _ nc (pid, mod_name, occ) =
272    let mod   = mkModule pid mod_name
273        cache = nsNames nc
274    in case lookupOrigNameCache cache  mod occ of
275           Just name -> (nc, name)
276           Nothing   ->
277               let (uniq, us) = takeUniqFromSupply (nsUniqs nc)
278                   name       = mkExternalName uniq mod occ noSrcSpan
279                   new_cache  = extendNameCache cache mod occ name
280               in ( nc{ nsUniqs = us, nsNames = new_cache }, name )
281
282serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO ()
283serialiseName bh name _ = do
284    let mod = ASSERT2( isExternalName name, ppr name ) nameModule name
285    put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
286
287
288-- Note [Symbol table representation of names]
289-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
290--
291-- An occurrence of a name in an interface file is serialized as a single 32-bit word.
292-- The format of this word is:
293--  00xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
294--   A normal name. x is an index into the symbol table
295--  01xxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyy
296--   A known-key name. x is the Unique's Char, y is the int part
297--  10xxyyzzzzzzzzzzzzzzzzzzzzzzzzzzzz
298--   A tuple name:
299--    x is the tuple sort (00b ==> boxed, 01b ==> unboxed, 10b ==> constraint)
300--    y is the thing (00b ==> tycon, 01b ==> datacon, 10b ==> datacon worker)
301--    z is the arity
302--  11xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
303--   An implicit parameter TyCon name. x is an index into the FastString *dictionary*
304--
305-- Note that we have to have special representation for tuples and IP TyCons because they
306-- form an "infinite" family and hence are not recorded explicitly in wiredInTyThings or
307-- basicKnownKeyNames.
308
309knownKeyNamesMap :: UniqFM Name
310knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames]
311  where
312    knownKeyNames :: [Name]
313    knownKeyNames = map getName wiredInThings ++ basicKnownKeyNames
314
315
316-- See Note [Symbol table representation of names]
317putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
318putName dict BinSymbolTable{ 
319               bin_symtab_map = symtab_map_ref,
320               bin_symtab_next = symtab_next }    bh name
321  | name `elemUFM` knownKeyNamesMap
322  , let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
323  = -- ASSERT(u < 2^(22 :: Int))
324    put_ bh (0x40000000 .|. (fromIntegral (ord c) `shiftL` 22) .|. (fromIntegral u :: Word32))
325  | otherwise
326  = case wiredInNameTyThing_maybe name of
327     Just (ATyCon tc)
328       | isTupleTyCon tc             -> putTupleName_ bh tc 0
329       | Just ip <- tyConIP_maybe tc -> do
330         off <- allocateFastString dict (ipFastString ip)
331         -- MASSERT(off < 2^(30 :: Int))
332         put_ bh (0xC0000000 .|. off)
333     Just (ADataCon dc)
334       | let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 1
335     Just (AnId x)
336       | Just dc <- isDataConWorkId_maybe x, let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 2
337     _ -> do
338       symtab_map <- readIORef symtab_map_ref
339       case lookupUFM symtab_map name of
340         Just (off,_) -> put_ bh (fromIntegral off :: Word32)
341         Nothing -> do
342            off <- readFastMutInt symtab_next
343            -- MASSERT(off < 2^(30 :: Int))
344            writeFastMutInt symtab_next (off+1)
345            writeIORef symtab_map_ref
346                $! addToUFM symtab_map name (off,name)
347            put_ bh (fromIntegral off :: Word32)
348
349putTupleName_ :: BinHandle -> TyCon -> Word32 -> IO ()
350putTupleName_ bh tc thing_tag
351  = -- ASSERT(arity < 2^(30 :: Int))
352    put_ bh (0x80000000 .|. (sort_tag `shiftL` 28) .|. (thing_tag `shiftL` 26) .|. arity)
353  where
354    arity = fromIntegral (tupleTyConArity tc)
355    sort_tag = case tupleTyConSort tc of
356        BoxedTuple      -> 0
357        UnboxedTuple    -> 1
358        ConstraintTuple -> 2
359
360-- See Note [Symbol table representation of names]
361getSymtabName :: NameCacheUpdater
362              -> Dictionary -> SymbolTable
363              -> BinHandle -> IO Name
364getSymtabName ncu dict symtab bh = do
365    i <- get bh
366    case i .&. 0xC0000000 of
367        0x00000000 -> return $! symtab ! fromIntegral (i :: Â Word32)
368        0x40000000 -> return $! case lookupUFM_Directly knownKeyNamesMap (mkUnique tag ix) of
369                        Nothing -> pprPanic "getSymtabName:unknown known-key unique" (ppr i)
370                        Just n  -> n
371          where tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
372                ix = fromIntegral i .&. 0x003FFFFF
373        0x80000000 -> return $! case thing_tag of
374                        0 -> tyConName (tupleTyCon sort arity)
375                        1 -> dataConName dc
376                        2 -> idName (dataConWorkId dc)
377                        _ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i)
378          where
379            dc = tupleCon sort arity
380            sort = case (i .&. 0x30000000) `shiftR` 28 of
381                     0 -> BoxedTuple
382                     1 -> UnboxedTuple
383                     2 -> ConstraintTuple
384                     _ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i)
385            thing_tag = (i .&. 0x0CFFFFFF) `shiftR` 26
386            arity = fromIntegral (i .&. 0x03FFFFFF)
387        0xC0000000 -> liftM ipTyConName $ updateNameCache ncu $ flip allocateIPName (dict ! fromIntegral (i .&. 0x3FFFFFFF))
388        _          -> pprPanic "getSymtabName:unknown name tag" (ppr i)
389
390data BinSymbolTable = BinSymbolTable {
391        bin_symtab_next :: !FastMutInt, -- The next index to use
392        bin_symtab_map  :: !(IORef (UniqFM (Int,Name)))
393                                -- indexed by Name
394  }
395
396
397putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
398putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
399
400allocateFastString :: BinDictionary -> FastString -> IO Word32
401allocateFastString BinDictionary { bin_dict_next = j_r,
402                                   bin_dict_map  = out_r} f = do
403    out <- readIORef out_r
404    let uniq = getUnique f
405    case lookupUFM out uniq of
406        Just (j, _)  -> return (fromIntegral j :: Word32)
407        Nothing -> do
408           j <- readFastMutInt j_r
409           writeFastMutInt j_r (j + 1)
410           writeIORef out_r $! addToUFM out uniq (j, f)
411           return (fromIntegral j :: Word32)
412
413getDictFastString :: Dictionary -> BinHandle -> IO FastString
414getDictFastString dict bh = do
415    j <- get bh
416    return $! (dict ! fromIntegral (j :: Word32))
417
418data BinDictionary = BinDictionary {
419        bin_dict_next :: !FastMutInt, -- The next index to use
420        bin_dict_map  :: !(IORef (UniqFM (Int,FastString)))
421                                -- indexed by FastString
422  }
423
424-- -----------------------------------------------------------------------------
425-- All the binary instances
426
427-- BasicTypes
428{-! for IPName derive: Binary !-}
429{-! for Fixity derive: Binary !-}
430{-! for FixityDirection derive: Binary !-}
431{-! for Boxity derive: Binary !-}
432{-! for StrictnessMark derive: Binary !-}
433{-! for Activation derive: Binary !-}
434
435-- Demand
436{-! for Demand derive: Binary !-}
437{-! for Demands derive: Binary !-}
438{-! for DmdResult derive: Binary !-}
439{-! for StrictSig derive: Binary !-}
440
441-- Class
442{-! for DefMeth derive: Binary !-}
443
444-- HsTypes
445{-! for HsPred derive: Binary !-}
446{-! for HsType derive: Binary !-}
447{-! for TupCon derive: Binary !-}
448{-! for HsTyVarBndr derive: Binary !-}
449
450-- HsCore
451{-! for UfExpr derive: Binary !-}
452{-! for UfConAlt derive: Binary !-}
453{-! for UfBinding derive: Binary !-}
454{-! for UfBinder derive: Binary !-}
455{-! for HsIdInfo derive: Binary !-}
456{-! for UfNote derive: Binary !-}
457
458-- HsDecls
459{-! for ConDetails derive: Binary !-}
460{-! for BangType derive: Binary !-}
461
462-- CostCentre
463{-! for IsCafCC derive: Binary !-}
464{-! for CostCentre derive: Binary !-}
465
466
467
468-- ---------------------------------------------------------------------------
469-- Reading a binary interface into ParsedIface
470
471instance Binary ModIface where
472   put_ bh (ModIface {
473                 mi_module    = mod,
474                 mi_boot      = is_boot,
475                 mi_iface_hash= iface_hash,
476                 mi_mod_hash  = mod_hash,
477                 mi_flag_hash = flag_hash,
478                 mi_orphan    = orphan,
479                 mi_finsts    = hasFamInsts,
480                 mi_deps      = deps,
481                 mi_usages    = usages,
482                 mi_exports   = exports,
483                 mi_exp_hash  = exp_hash,
484                 mi_used_th   = used_th,
485                 mi_fixities  = fixities,
486                 mi_warns     = warns,
487                 mi_anns      = anns,
488                 mi_decls     = decls,
489                 mi_insts     = insts,
490                 mi_fam_insts = fam_insts,
491                 mi_rules     = rules,
492                 mi_orphan_hash = orphan_hash,
493                 mi_vect_info = vect_info,
494                 mi_hpc       = hpc_info,
495                 mi_trust     = trust,
496                 mi_trust_pkg = trust_pkg }) = do
497        put_ bh mod
498        put_ bh is_boot
499        put_ bh iface_hash
500        put_ bh mod_hash
501        put_ bh flag_hash
502        put_ bh orphan
503        put_ bh hasFamInsts
504        lazyPut bh deps
505        lazyPut bh usages
506        put_ bh exports
507        put_ bh exp_hash
508        put_ bh used_th
509        put_ bh fixities
510        lazyPut bh warns
511        lazyPut bh anns
512        put_ bh decls
513        put_ bh insts
514        put_ bh fam_insts
515        lazyPut bh rules
516        put_ bh orphan_hash
517        put_ bh vect_info
518        put_ bh hpc_info
519        put_ bh trust
520        put_ bh trust_pkg
521
522   get bh = do
523        mod_name    <- get bh
524        is_boot     <- get bh
525        iface_hash  <- get bh
526        mod_hash    <- get bh
527        flag_hash   <- get bh
528        orphan      <- get bh
529        hasFamInsts <- get bh
530        deps        <- lazyGet bh
531        usages      <- {-# SCC "bin_usages" #-} lazyGet bh
532        exports     <- {-# SCC "bin_exports" #-} get bh
533        exp_hash    <- get bh
534        used_th     <- get bh
535        fixities    <- {-# SCC "bin_fixities" #-} get bh
536        warns       <- {-# SCC "bin_warns" #-} lazyGet bh
537        anns        <- {-# SCC "bin_anns" #-} lazyGet bh
538        decls       <- {-# SCC "bin_tycldecls" #-} get bh
539        insts       <- {-# SCC "bin_insts" #-} get bh
540        fam_insts   <- {-# SCC "bin_fam_insts" #-} get bh
541        rules       <- {-# SCC "bin_rules" #-} lazyGet bh
542        orphan_hash <- get bh
543        vect_info   <- get bh
544        hpc_info    <- get bh
545        trust       <- get bh
546        trust_pkg   <- get bh
547        return (ModIface {
548                 mi_module      = mod_name,
549                 mi_boot        = is_boot,
550                 mi_iface_hash  = iface_hash,
551                 mi_mod_hash    = mod_hash,
552                 mi_flag_hash   = flag_hash,
553                 mi_orphan      = orphan,
554                 mi_finsts      = hasFamInsts,
555                 mi_deps        = deps,
556                 mi_usages      = usages,
557                 mi_exports     = exports,
558                 mi_exp_hash    = exp_hash,
559                 mi_used_th     = used_th,
560                 mi_anns        = anns,
561                 mi_fixities    = fixities,
562                 mi_warns       = warns,
563                 mi_decls       = decls,
564                 mi_globals     = Nothing,
565                 mi_insts       = insts,
566                 mi_fam_insts   = fam_insts,
567                 mi_rules       = rules,
568                 mi_orphan_hash = orphan_hash,
569                 mi_vect_info   = vect_info,
570                 mi_hpc         = hpc_info,
571                 mi_trust       = trust,
572                 mi_trust_pkg   = trust_pkg,
573                        -- And build the cached values
574                 mi_warn_fn     = mkIfaceWarnCache warns,
575                 mi_fix_fn      = mkIfaceFixCache fixities,
576                 mi_hash_fn     = mkIfaceHashCache decls })
577
578getWayDescr :: DynFlags -> String
579getWayDescr dflags
580  | cGhcUnregisterised == "YES" = 'u':tag
581  | otherwise                   = tag
582  where tag = buildTag dflags
583        -- if this is an unregisterised build, make sure our interfaces
584        -- can't be used by a registerised build.
585
586-------------------------------------------------------------------------
587--              Types from: HscTypes
588-------------------------------------------------------------------------
589
590instance Binary Dependencies where
591    put_ bh deps = do put_ bh (dep_mods deps)
592                      put_ bh (dep_pkgs deps)
593                      put_ bh (dep_orphs deps)
594                      put_ bh (dep_finsts deps)
595
596    get bh = do ms <- get bh
597                ps <- get bh
598                os <- get bh
599                fis <- get bh
600                return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
601                               dep_finsts = fis })
602
603instance Binary AvailInfo where
604    put_ bh (Avail aa) = do
605            putByte bh 0
606            put_ bh aa
607    put_ bh (AvailTC ab ac) = do
608            putByte bh 1
609            put_ bh ab
610            put_ bh ac
611    get bh = do
612            h <- getByte bh
613            case h of
614              0 -> do aa <- get bh
615                      return (Avail aa)
616              _ -> do ab <- get bh
617                      ac <- get bh
618                      return (AvailTC ab ac)
619
620instance Binary Usage where
621    put_ bh usg@UsagePackageModule{} = do 
622        putByte bh 0
623        put_ bh (usg_mod usg)
624        put_ bh (usg_mod_hash usg)
625        put_ bh (usg_safe     usg)
626
627    put_ bh usg@UsageHomeModule{} = do 
628        putByte bh 1
629        put_ bh (usg_mod_name usg)
630        put_ bh (usg_mod_hash usg)
631        put_ bh (usg_exports  usg)
632        put_ bh (usg_entities usg)
633        put_ bh (usg_safe     usg)
634
635    put_ bh usg@UsageFile{} = do 
636        putByte bh 2
637        put_ bh (usg_file_path usg)
638        put_ bh (usg_mtime     usg)
639
640    get bh = do
641        h <- getByte bh
642        case h of
643          0 -> do
644            nm    <- get bh
645            mod   <- get bh
646            safe  <- get bh
647            return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
648          1 -> do
649            nm    <- get bh
650            mod   <- get bh
651            exps  <- get bh
652            ents  <- get bh
653            safe  <- get bh
654            return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
655                     usg_exports = exps, usg_entities = ents, usg_safe = safe }
656          2 -> do
657            fp    <- get bh
658            mtime <- get bh
659            return UsageFile { usg_file_path = fp, usg_mtime = mtime }
660          i -> error ("Binary.get(Usage): " ++ show i)
661
662instance Binary Warnings where
663    put_ bh NoWarnings     = putByte bh 0
664    put_ bh (WarnAll t) = do
665            putByte bh 1
666            put_ bh t
667    put_ bh (WarnSome ts) = do
668            putByte bh 2
669            put_ bh ts
670
671    get bh = do
672            h <- getByte bh
673            case h of
674              0 -> return NoWarnings
675              1 -> do aa <- get bh
676                      return (WarnAll aa)
677              _ -> do aa <- get bh
678                      return (WarnSome aa)
679
680instance Binary WarningTxt where
681    put_ bh (WarningTxt w) = do
682            putByte bh 0
683            put_ bh w
684    put_ bh (DeprecatedTxt d) = do
685            putByte bh 1
686            put_ bh d
687
688    get bh = do
689            h <- getByte bh
690            case h of
691              0 -> do w <- get bh
692                      return (WarningTxt w)
693              _ -> do d <- get bh
694                      return (DeprecatedTxt d)
695
696-------------------------------------------------------------------------
697--              Types from: BasicTypes
698-------------------------------------------------------------------------
699
700instance Binary Activation where
701    put_ bh NeverActive = do
702            putByte bh 0
703    put_ bh AlwaysActive = do
704            putByte bh 1
705    put_ bh (ActiveBefore aa) = do
706            putByte bh 2
707            put_ bh aa
708    put_ bh (ActiveAfter ab) = do
709            putByte bh 3
710            put_ bh ab
711    get bh = do
712            h <- getByte bh
713            case h of
714              0 -> do return NeverActive
715              1 -> do return AlwaysActive
716              2 -> do aa <- get bh
717                      return (ActiveBefore aa)
718              _ -> do ab <- get bh
719                      return (ActiveAfter ab)
720
721instance Binary RuleMatchInfo where
722    put_ bh FunLike = putByte bh 0
723    put_ bh ConLike = putByte bh 1
724    get bh = do
725            h <- getByte bh
726            if h == 1 then return ConLike
727                      else return FunLike
728
729instance Binary InlinePragma where
730    put_ bh (InlinePragma a b c d) = do
731            put_ bh a
732            put_ bh b
733            put_ bh c
734            put_ bh d
735
736    get bh = do
737           a <- get bh
738           b <- get bh
739           c <- get bh
740           d <- get bh
741           return (InlinePragma a b c d)
742
743instance Binary InlineSpec where
744    put_ bh EmptyInlineSpec = putByte bh 0
745    put_ bh Inline          = putByte bh 1
746    put_ bh Inlinable       = putByte bh 2
747    put_ bh NoInline        = putByte bh 3
748
749    get bh = do h <- getByte bh
750                case h of
751                  0 -> return EmptyInlineSpec
752                  1 -> return Inline
753                  2 -> return Inlinable
754                  _ -> return NoInline
755
756instance Binary HsBang where
757    put_ bh HsNoBang        = putByte bh 0
758    put_ bh HsStrict        = putByte bh 1
759    put_ bh HsUnpack        = putByte bh 2
760    put_ bh HsUnpackFailed  = putByte bh 3
761    put_ bh HsNoUnpack      = putByte bh 4
762    get bh = do
763            h <- getByte bh
764            case h of
765              0 -> do return HsNoBang
766              1 -> do return HsStrict
767              2 -> do return HsUnpack
768              3 -> do return HsUnpackFailed
769              _ -> do return HsNoUnpack
770
771instance Binary TupleSort where
772    put_ bh BoxedTuple      = putByte bh 0
773    put_ bh UnboxedTuple    = putByte bh 1
774    put_ bh ConstraintTuple = putByte bh 2
775    get bh = do
776      h <- getByte bh
777      case h of
778        0 -> do return BoxedTuple
779        1 -> do return UnboxedTuple
780        _ -> do return ConstraintTuple
781
782instance Binary RecFlag where
783    put_ bh Recursive = do
784            putByte bh 0
785    put_ bh NonRecursive = do
786            putByte bh 1
787    get bh = do
788            h <- getByte bh
789            case h of
790              0 -> do return Recursive
791              _ -> do return NonRecursive
792
793instance Binary DefMethSpec where
794    put_ bh NoDM      = putByte bh 0
795    put_ bh VanillaDM = putByte bh 1
796    put_ bh GenericDM = putByte bh 2
797    get bh = do
798            h <- getByte bh
799            case h of
800              0 -> return NoDM
801              1 -> return VanillaDM
802              _ -> return GenericDM
803
804instance Binary FixityDirection where
805    put_ bh InfixL = do
806            putByte bh 0
807    put_ bh InfixR = do
808            putByte bh 1
809    put_ bh InfixN = do
810            putByte bh 2
811    get bh = do
812            h <- getByte bh
813            case h of
814              0 -> do return InfixL
815              1 -> do return InfixR
816              _ -> do return InfixN
817
818instance Binary Fixity where
819    put_ bh (Fixity aa ab) = do
820            put_ bh aa
821            put_ bh ab
822    get bh = do
823          aa <- get bh
824          ab <- get bh
825          return (Fixity aa ab)
826
827instance (Binary name) => Binary (IPName name) where
828    put_ bh (IPName aa) = put_ bh aa
829    get bh = do aa <- get bh
830                return (IPName aa)
831
832-------------------------------------------------------------------------
833--              Types from: Demand
834-------------------------------------------------------------------------
835
836instance Binary DmdType where
837        -- Ignore DmdEnv when spitting out the DmdType
838  put bh (DmdType _ ds dr) = do p <- put bh ds; put_ bh dr; return (castBin p)
839  get bh = do ds <- get bh; dr <- get bh; return (DmdType emptyVarEnv ds dr)
840
841instance Binary Demand where
842    put_ bh Top = do
843            putByte bh 0
844    put_ bh Abs = do
845            putByte bh 1
846    put_ bh (Call aa) = do
847            putByte bh 2
848            put_ bh aa
849    put_ bh (Eval ab) = do
850            putByte bh 3
851            put_ bh ab
852    put_ bh (Defer ac) = do
853            putByte bh 4
854            put_ bh ac
855    put_ bh (Box ad) = do
856            putByte bh 5
857            put_ bh ad
858    put_ bh Bot = do
859            putByte bh 6
860    get bh = do
861            h <- getByte bh
862            case h of
863              0 -> do return Top
864              1 -> do return Abs
865              2 -> do aa <- get bh
866                      return (Call aa)
867              3 -> do ab <- get bh
868                      return (Eval ab)
869              4 -> do ac <- get bh
870                      return (Defer ac)
871              5 -> do ad <- get bh
872                      return (Box ad)
873              _ -> do return Bot
874
875instance Binary Demands where
876    put_ bh (Poly aa) = do
877            putByte bh 0
878            put_ bh aa
879    put_ bh (Prod ab) = do
880            putByte bh 1
881            put_ bh ab
882    get bh = do
883            h <- getByte bh
884            case h of
885              0 -> do aa <- get bh
886                      return (Poly aa)
887              _ -> do ab <- get bh
888                      return (Prod ab)
889
890instance Binary DmdResult where
891    put_ bh TopRes = do
892            putByte bh 0
893    put_ bh RetCPR = do
894            putByte bh 1
895    put_ bh BotRes = do
896            putByte bh 2
897    get bh = do
898            h <- getByte bh
899            case h of
900              0 -> do return TopRes
901              1 -> do return RetCPR     -- Really use RetCPR even if -fcpr-off
902                                        -- The wrapper was generated for CPR in
903                                        -- the imported module!
904              _ -> do return BotRes
905
906instance Binary StrictSig where
907    put_ bh (StrictSig aa) = do
908            put_ bh aa
909    get bh = do
910          aa <- get bh
911          return (StrictSig aa)
912
913
914-------------------------------------------------------------------------
915--              Types from: CostCentre
916-------------------------------------------------------------------------
917
918instance Binary IsCafCC where
919    put_ bh CafCC = do
920            putByte bh 0
921    put_ bh NotCafCC = do
922            putByte bh 1
923    get bh = do
924            h <- getByte bh
925            case h of
926              0 -> do return CafCC
927              _ -> do return NotCafCC
928
929instance Binary CostCentre where
930    put_ bh (NormalCC aa ab ac _ad ae) = do
931            putByte bh 0
932            put_ bh aa
933            put_ bh ab
934            put_ bh ac
935            put_ bh ae
936    put_ bh (AllCafsCC ae _af) = do
937            putByte bh 1
938            put_ bh ae
939    get bh = do
940            h <- getByte bh
941            case h of
942              0 -> do aa <- get bh
943                      ab <- get bh
944                      ac <- get bh
945                      ae <- get bh
946                      return (NormalCC aa ab ac noSrcSpan ae)
947              _ -> do ae <- get bh
948                      return (AllCafsCC ae noSrcSpan)
949
950    -- We ignore the SrcSpans in CostCentres when we serialise them,
951    -- and set the SrcSpans to noSrcSpan when deserialising.  This is
952    -- ok, because we only need the SrcSpan when declaring the
953    -- CostCentre in the original module, it is not used by importing
954    -- modules.
955
956-------------------------------------------------------------------------
957--              IfaceTypes and friends
958-------------------------------------------------------------------------
959
960instance Binary IfaceBndr where
961    put_ bh (IfaceIdBndr aa) = do
962            putByte bh 0
963            put_ bh aa
964    put_ bh (IfaceTvBndr ab) = do
965            putByte bh 1
966            put_ bh ab
967    get bh = do
968            h <- getByte bh
969            case h of
970              0 -> do aa <- get bh
971                      return (IfaceIdBndr aa)
972              _ -> do ab <- get bh
973                      return (IfaceTvBndr ab)
974
975instance Binary IfaceLetBndr where
976    put_ bh (IfLetBndr a b c) = do
977            put_ bh a
978            put_ bh b
979            put_ bh c
980    get bh = do a <- get bh
981                b <- get bh
982                c <- get bh
983                return (IfLetBndr a b c)           
984
985instance Binary IfaceType where
986    put_ bh (IfaceForAllTy aa ab) = do
987            putByte bh 0
988            put_ bh aa
989            put_ bh ab
990    put_ bh (IfaceTyVar ad) = do
991            putByte bh 1
992            put_ bh ad
993    put_ bh (IfaceAppTy ae af) = do
994            putByte bh 2
995            put_ bh ae
996            put_ bh af
997    put_ bh (IfaceFunTy ag ah) = do
998            putByte bh 3
999            put_ bh ag
1000            put_ bh ah
1001    put_ bh (IfaceCoConApp cc tys)
1002      = do { putByte bh 4; put_ bh cc; put_ bh tys }
1003    put_ bh (IfaceTyConApp tc tys)
1004      = do { putByte bh 5; put_ bh tc; put_ bh tys }
1005
1006    put_ bh (IfaceLitTy n)
1007      = do { putByte bh 30; put_ bh n }
1008
1009
1010    get bh = do
1011            h <- getByte bh
1012            case h of
1013              0 -> do aa <- get bh
1014                      ab <- get bh
1015                      return (IfaceForAllTy aa ab)
1016              1 -> do ad <- get bh
1017                      return (IfaceTyVar ad)
1018              2 -> do ae <- get bh
1019                      af <- get bh
1020                      return (IfaceAppTy ae af)
1021              3 -> do ag <- get bh
1022                      ah <- get bh
1023                      return (IfaceFunTy ag ah)
1024              4 -> do { cc <- get bh; tys <- get bh
1025                      ; return (IfaceCoConApp cc tys) }
1026              5 -> do { tc <- get bh; tys <- get bh
1027                      ; return (IfaceTyConApp tc tys) }
1028
1029              30 -> do n <- get bh
1030                       return (IfaceLitTy n)
1031
1032              _  -> panic ("get IfaceType " ++ show h)
1033
1034instance Binary IfaceTyLit where
1035  put_ bh (IfaceNumTyLit n)  = putByte bh 1 >> put_ bh n
1036  put_ bh (IfaceStrTyLit n)  = putByte bh 2 >> put_ bh n
1037
1038  get bh =
1039    do tag <- getByte bh
1040       case tag of
1041         1 -> do { n <- get bh
1042                 ; return (IfaceNumTyLit n) }
1043         2 -> do { n <- get bh
1044                 ; return (IfaceStrTyLit n) }
1045         _ -> panic ("get IfaceTyLit " ++ show tag)
1046
1047instance Binary IfaceTyCon where
1048   put_ bh (IfaceTc ext) = put_ bh ext
1049   get bh = liftM IfaceTc (get bh)
1050
1051instance Binary IfaceCoCon where
1052   put_ bh (IfaceCoAx n)       = do { putByte bh 0; put_ bh n }
1053   put_ bh IfaceReflCo         = putByte bh 1
1054   put_ bh IfaceUnsafeCo       = putByte bh 2
1055   put_ bh IfaceSymCo          = putByte bh 3
1056   put_ bh IfaceTransCo        = putByte bh 4
1057   put_ bh IfaceInstCo         = putByte bh 5
1058   put_ bh (IfaceNthCo d)      = do { putByte bh 6; put_ bh d }
1059   put_ bh (IfaceIPCoAx ip)    = do { putByte bh 7; put_ bh ip }
1060 
1061   get bh = do
1062        h <- getByte bh
1063        case h of
1064          0 -> do { n <- get bh; return (IfaceCoAx n) }
1065          1 -> return IfaceReflCo 
1066          2 -> return IfaceUnsafeCo
1067          3 -> return IfaceSymCo
1068          4 -> return IfaceTransCo
1069          5 -> return IfaceInstCo
1070          6 -> do { d <- get bh; return (IfaceNthCo d) }
1071          7 -> do { ip <- get bh; return (IfaceIPCoAx ip) }
1072          _ -> panic ("get IfaceCoCon " ++ show h)
1073
1074-------------------------------------------------------------------------
1075--              IfaceExpr and friends
1076-------------------------------------------------------------------------
1077
1078instance Binary IfaceExpr where
1079    put_ bh (IfaceLcl aa) = do
1080        putByte bh 0
1081        put_ bh aa
1082    put_ bh (IfaceType ab) = do
1083        putByte bh 1
1084        put_ bh ab
1085    put_ bh (IfaceCo ab) = do
1086        putByte bh 2
1087        put_ bh ab
1088    put_ bh (IfaceTuple ac ad) = do
1089        putByte bh 3
1090        put_ bh ac
1091        put_ bh ad
1092    put_ bh (IfaceLam ae af) = do
1093        putByte bh 4
1094        put_ bh ae
1095        put_ bh af
1096    put_ bh (IfaceApp ag ah) = do
1097        putByte bh 5
1098        put_ bh ag
1099        put_ bh ah
1100    put_ bh (IfaceCase ai aj ak) = do
1101        putByte bh 6
1102        put_ bh ai
1103        put_ bh aj
1104        put_ bh ak
1105    put_ bh (IfaceLet al am) = do
1106        putByte bh 7
1107        put_ bh al
1108        put_ bh am
1109    put_ bh (IfaceTick an ao) = do
1110        putByte bh 8
1111        put_ bh an
1112        put_ bh ao
1113    put_ bh (IfaceLit ap) = do
1114        putByte bh 9
1115        put_ bh ap
1116    put_ bh (IfaceFCall as at) = do
1117        putByte bh 10
1118        put_ bh as
1119        put_ bh at
1120    put_ bh (IfaceExt aa) = do
1121        putByte bh 11
1122        put_ bh aa
1123    put_ bh (IfaceCast ie ico) = do
1124        putByte bh 12
1125        put_ bh ie
1126        put_ bh ico
1127    put_ bh (IfaceECase a b) = do
1128        putByte bh 13
1129        put_ bh a
1130        put_ bh b
1131    get bh = do
1132        h <- getByte bh
1133        case h of
1134            0 -> do aa <- get bh
1135                    return (IfaceLcl aa)
1136            1 -> do ab <- get bh
1137                    return (IfaceType ab)
1138            2 -> do ab <- get bh
1139                    return (IfaceCo ab)
1140            3 -> do ac <- get bh
1141                    ad <- get bh
1142                    return (IfaceTuple ac ad)
1143            4 -> do ae <- get bh
1144                    af <- get bh
1145                    return (IfaceLam ae af)
1146            5 -> do ag <- get bh
1147                    ah <- get bh
1148                    return (IfaceApp ag ah)
1149            6 -> do ai <- get bh
1150                    aj <- get bh
1151                    ak <- get bh
1152                    return (IfaceCase ai aj ak)
1153            7 -> do al <- get bh
1154                    am <- get bh
1155                    return (IfaceLet al am)
1156            8 -> do an <- get bh
1157                    ao <- get bh
1158                    return (IfaceTick an ao)
1159            9 -> do ap <- get bh
1160                    return (IfaceLit ap)
1161            10 -> do as <- get bh
1162                     at <- get bh
1163                     return (IfaceFCall as at)
1164            11 -> do aa <- get bh
1165                     return (IfaceExt aa)
1166            12 -> do ie <- get bh
1167                     ico <- get bh
1168                     return (IfaceCast ie ico)
1169            13 -> do a <- get bh
1170                     b <- get bh
1171                     return (IfaceECase a b)
1172            _ -> panic ("get IfaceExpr " ++ show h)
1173
1174instance Binary IfaceConAlt where
1175    put_ bh IfaceDefault      = putByte bh 0
1176    put_ bh (IfaceDataAlt aa) = putByte bh 1 >> put_ bh aa
1177    put_ bh (IfaceLitAlt ac)  = putByte bh 2 >> put_ bh ac
1178    get bh = do
1179        h <- getByte bh
1180        case h of
1181            0 -> return IfaceDefault
1182            1 -> get bh >>= (return . IfaceDataAlt)
1183            _ -> get bh >>= (return . IfaceLitAlt)
1184
1185instance Binary IfaceBinding where
1186    put_ bh (IfaceNonRec aa ab) = putByte bh 0 >> put_ bh aa >> put_ bh ab
1187    put_ bh (IfaceRec ac)       = putByte bh 1 >> put_ bh ac
1188    get bh = do
1189        h <- getByte bh
1190        case h of
1191            0 -> do { aa <- get bh; ab <- get bh; return (IfaceNonRec aa ab) }
1192            _ -> do { ac <- get bh; return (IfaceRec ac) }
1193
1194instance Binary IfaceIdDetails where
1195    put_ bh IfVanillaId      = putByte bh 0
1196    put_ bh (IfRecSelId a b) = putByte bh 1 >> put_ bh a >> put_ bh b
1197    put_ bh IfDFunId         = putByte bh 2
1198    get bh = do
1199        h <- getByte bh
1200        case h of
1201            0 -> return IfVanillaId
1202            1 -> do { a <- get bh; b <- get bh; return (IfRecSelId a b) }
1203            _ -> return IfDFunId
1204
1205instance Binary IfaceIdInfo where
1206    put_ bh NoInfo      = putByte bh 0
1207    put_ bh (HasInfo i) = putByte bh 1 >> lazyPut bh i -- NB lazyPut
1208
1209    get bh = do
1210        h <- getByte bh
1211        case h of
1212            0 -> return NoInfo
1213            _ -> lazyGet bh >>= (return . HasInfo)     -- NB lazyGet
1214
1215instance Binary IfaceInfoItem where
1216    put_ bh (HsArity aa)      = putByte bh 0 >> put_ bh aa
1217    put_ bh (HsStrictness ab) = putByte bh 1 >> put_ bh ab
1218    put_ bh (HsUnfold lb ad)  = putByte bh 2 >> put_ bh lb >> put_ bh ad
1219    put_ bh (HsInline ad)     = putByte bh 3 >> put_ bh ad
1220    put_ bh HsNoCafRefs       = putByte bh 4
1221    get bh = do
1222        h <- getByte bh
1223        case h of
1224            0 -> get bh >>= (return . HsArity)
1225            1 -> get bh >>= (return . HsStrictness)
1226            2 -> do lb <- get bh
1227                    ad <- get bh
1228                    return (HsUnfold lb ad)
1229            3 -> get bh >>= (return . HsInline)
1230            _ -> return HsNoCafRefs
1231
1232instance Binary IfaceUnfolding where
1233    put_ bh (IfCoreUnfold s e) = do
1234        putByte bh 0
1235        put_ bh s
1236        put_ bh e
1237    put_ bh (IfInlineRule a b c d) = do
1238        putByte bh 1
1239        put_ bh a
1240        put_ bh b
1241        put_ bh c
1242        put_ bh d
1243    put_ bh (IfLclWrapper a n) = do
1244        putByte bh 2
1245        put_ bh a
1246        put_ bh n
1247    put_ bh (IfExtWrapper a n) = do
1248        putByte bh 3
1249        put_ bh a
1250        put_ bh n
1251    put_ bh (IfDFunUnfold as) = do
1252        putByte bh 4
1253        put_ bh as
1254    put_ bh (IfCompulsory e) = do
1255        putByte bh 5
1256        put_ bh e
1257    get bh = do
1258        h <- getByte bh
1259        case h of
1260            0 -> do s <- get bh
1261                    e <- get bh
1262                    return (IfCoreUnfold s e)
1263            1 -> do a <- get bh
1264                    b <- get bh
1265                    c <- get bh
1266                    d <- get bh
1267                    return (IfInlineRule a b c d)
1268            2 -> do a <- get bh
1269                    n <- get bh
1270                    return (IfLclWrapper a n)
1271            3 -> do a <- get bh
1272                    n <- get bh
1273                    return (IfExtWrapper a n)
1274            4 -> do as <- get bh
1275                    return (IfDFunUnfold as)
1276            _ -> do e <- get bh
1277                    return (IfCompulsory e)
1278
1279instance Binary IfaceTickish where
1280    put_ bh (IfaceHpcTick m ix) = do
1281        putByte bh 0
1282        put_ bh m
1283        put_ bh ix
1284    put_ bh (IfaceSCC cc tick push) = do
1285        putByte bh 1
1286        put_ bh cc
1287        put_ bh tick
1288        put_ bh push
1289
1290    get bh = do
1291        h <- getByte bh
1292        case h of
1293            0 -> do m <- get bh
1294                    ix <- get bh
1295                    return (IfaceHpcTick m ix)
1296            1 -> do cc <- get bh
1297                    tick <- get bh
1298                    push <- get bh
1299                    return (IfaceSCC cc tick push)
1300            _ -> panic ("get IfaceTickish " ++ show h)
1301
1302-------------------------------------------------------------------------
1303--              IfaceDecl and friends
1304-------------------------------------------------------------------------
1305
1306-- A bit of magic going on here: there's no need to store the OccName
1307-- for a decl on the disk, since we can infer the namespace from the
1308-- context; however it is useful to have the OccName in the IfaceDecl
1309-- to avoid re-building it in various places.  So we build the OccName
1310-- when de-serialising.
1311
1312instance Binary IfaceDecl where
1313    put_ bh (IfaceId name ty details idinfo) = do
1314        putByte bh 0
1315        put_ bh (occNameFS name)
1316        put_ bh ty
1317        put_ bh details
1318        put_ bh idinfo
1319
1320    put_ _ (IfaceForeign _ _) = 
1321        error "Binary.put_(IfaceDecl): IfaceForeign"
1322
1323    put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do
1324        putByte bh 2
1325        put_ bh (occNameFS a1)
1326        put_ bh a2
1327        put_ bh a3
1328        put_ bh a4
1329        put_ bh a5
1330        put_ bh a6
1331        put_ bh a7
1332        put_ bh a8
1333
1334    put_ bh (IfaceSyn a1 a2 a3 a4) = do
1335        putByte bh 3
1336        put_ bh (occNameFS a1)
1337        put_ bh a2
1338        put_ bh a3
1339        put_ bh a4
1340
1341    put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do
1342        putByte bh 4
1343        put_ bh a1
1344        put_ bh (occNameFS a2)
1345        put_ bh a3
1346        put_ bh a4
1347        put_ bh a5
1348        put_ bh a6
1349        put_ bh a7
1350       
1351    put_ bh (IfaceAxiom a1 a2 a3 a4) = do
1352        putByte bh 5
1353        put_ bh (occNameFS a1)
1354        put_ bh a2
1355        put_ bh a3
1356        put_ bh a4
1357
1358    get bh = do
1359        h <- getByte bh
1360        case h of
1361            0 -> do name    <- get bh
1362                    ty      <- get bh
1363                    details <- get bh
1364                    idinfo  <- get bh
1365                    occ <- return $! mkOccNameFS varName name
1366                    return (IfaceId occ ty details idinfo)
1367            1 -> error "Binary.get(TyClDecl): ForeignType"
1368            2 -> do a1 <- get bh
1369                    a2 <- get bh
1370                    a3 <- get bh
1371                    a4 <- get bh
1372                    a5 <- get bh
1373                    a6 <- get bh
1374                    a7 <- get bh
1375                    a8 <- get bh
1376                    occ <- return $! mkOccNameFS tcName a1
1377                    return (IfaceData occ a2 a3 a4 a5 a6 a7 a8)
1378            3 -> do a1 <- get bh
1379                    a2 <- get bh
1380                    a3 <- get bh
1381                    a4 <- get bh
1382                    occ <- return $! mkOccNameFS tcName a1
1383                    return (IfaceSyn occ a2 a3 a4)
1384            4 -> do a1 <- get bh
1385                    a2 <- get bh
1386                    a3 <- get bh
1387                    a4 <- get bh
1388                    a5 <- get bh
1389                    a6 <- get bh
1390                    a7 <- get bh
1391                    occ <- return $! mkOccNameFS clsName a2
1392                    return (IfaceClass a1 occ a3 a4 a5 a6 a7)
1393            _ -> do a1 <- get bh
1394                    a2 <- get bh
1395                    a3 <- get bh
1396                    a4 <- get bh
1397                    occ <- return $! mkOccNameFS tcName a1
1398                    return (IfaceAxiom occ a2 a3 a4)
1399
1400instance Binary IfaceClsInst where
1401    put_ bh (IfaceClsInst cls tys dfun flag orph) = do
1402        put_ bh cls
1403        put_ bh tys
1404        put_ bh dfun
1405        put_ bh flag
1406        put_ bh orph
1407    get bh = do
1408        cls  <- get bh
1409        tys  <- get bh
1410        dfun <- get bh
1411        flag <- get bh
1412        orph <- get bh
1413        return (IfaceClsInst cls tys dfun flag orph)
1414
1415instance Binary IfaceFamInst where
1416    put_ bh (IfaceFamInst fam tys name orph) = do
1417        put_ bh fam
1418        put_ bh tys
1419        put_ bh name
1420        put_ bh orph
1421    get bh = do
1422        fam      <- get bh
1423        tys      <- get bh
1424        name     <- get bh
1425        orph     <- get bh
1426        return (IfaceFamInst fam tys name orph)
1427
1428instance Binary OverlapFlag where
1429    put_ bh (NoOverlap  b) = putByte bh 0 >> put_ bh b
1430    put_ bh (OverlapOk  b) = putByte bh 1 >> put_ bh b
1431    put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
1432    get bh = do
1433        h <- getByte bh
1434        b <- get bh
1435        case h of
1436            0 -> return $ NoOverlap b
1437            1 -> return $ OverlapOk b
1438            2 -> return $ Incoherent b
1439            _ -> panic ("get OverlapFlag " ++ show h)
1440
1441instance Binary IfaceConDecls where
1442    put_ bh (IfAbstractTyCon d) = putByte bh 0 >> put_ bh d
1443    put_ bh IfDataFamTyCon     = putByte bh 1
1444    put_ bh (IfDataTyCon cs)    = putByte bh 2 >> put_ bh cs
1445    put_ bh (IfNewTyCon c)      = putByte bh 3 >> put_ bh c
1446    get bh = do
1447        h <- getByte bh
1448        case h of
1449            0 -> get bh >>= (return . IfAbstractTyCon)
1450            1 -> return IfDataFamTyCon
1451            2 -> get bh >>= (return . IfDataTyCon)
1452            _ -> get bh >>= (return . IfNewTyCon)
1453
1454instance Binary IfaceConDecl where
1455    put_ bh (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10) = do
1456        put_ bh a1
1457        put_ bh a2
1458        put_ bh a3
1459        put_ bh a4
1460        put_ bh a5
1461        put_ bh a6
1462        put_ bh a7
1463        put_ bh a8
1464        put_ bh a9
1465        put_ bh a10
1466    get bh = do
1467        a1 <- get bh
1468        a2 <- get bh
1469        a3 <- get bh         
1470        a4 <- get bh
1471        a5 <- get bh
1472        a6 <- get bh
1473        a7 <- get bh
1474        a8 <- get bh
1475        a9 <- get bh
1476        a10 <- get bh
1477        return (IfCon a1 a2 a3 a4 a5 a6 a7 a8 a9 a10)
1478
1479instance Binary IfaceAT where
1480    put_ bh (IfaceAT dec defs) = do
1481        put_ bh dec
1482        put_ bh defs
1483    get bh = do
1484        dec  <- get bh
1485        defs <- get bh
1486        return (IfaceAT dec defs)
1487
1488instance Binary IfaceATDefault where
1489    put_ bh (IfaceATD tvs pat_tys ty) = do
1490        put_ bh tvs
1491        put_ bh pat_tys
1492        put_ bh ty
1493    get bh = liftM3 IfaceATD (get bh) (get bh) (get bh)
1494
1495instance Binary IfaceClassOp where
1496    put_ bh (IfaceClassOp n def ty) = do 
1497        put_ bh (occNameFS n)
1498        put_ bh def     
1499        put_ bh ty
1500    get bh = do
1501        n   <- get bh
1502        def <- get bh
1503        ty  <- get bh
1504        occ <- return $! mkOccNameFS varName n
1505        return (IfaceClassOp occ def ty)
1506
1507instance Binary IfaceRule where
1508    put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8) = do
1509        put_ bh a1
1510        put_ bh a2
1511        put_ bh a3
1512        put_ bh a4
1513        put_ bh a5
1514        put_ bh a6
1515        put_ bh a7
1516        put_ bh a8
1517    get bh = do
1518        a1 <- get bh
1519        a2 <- get bh
1520        a3 <- get bh
1521        a4 <- get bh
1522        a5 <- get bh
1523        a6 <- get bh
1524        a7 <- get bh
1525        a8 <- get bh
1526        return (IfaceRule a1 a2 a3 a4 a5 a6 a7 a8)
1527
1528instance Binary IfaceAnnotation where
1529    put_ bh (IfaceAnnotation a1 a2) = do
1530        put_ bh a1
1531        put_ bh a2
1532    get bh = do
1533        a1 <- get bh
1534        a2 <- get bh
1535        return (IfaceAnnotation a1 a2)
1536
1537instance Binary name => Binary (AnnTarget name) where
1538    put_ bh (NamedTarget a) = do
1539        putByte bh 0
1540        put_ bh a
1541    put_ bh (ModuleTarget a) = do
1542        putByte bh 1
1543        put_ bh a
1544    get bh = do
1545        h <- getByte bh
1546        case h of
1547            0 -> get bh >>= (return . NamedTarget)
1548            _ -> get bh >>= (return . ModuleTarget)
1549
1550instance Binary IfaceVectInfo where
1551    put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
1552        put_ bh a1
1553        put_ bh a2
1554        put_ bh a3
1555        put_ bh a4
1556        put_ bh a5
1557    get bh = do
1558        a1 <- get bh
1559        a2 <- get bh
1560        a3 <- get bh
1561        a4 <- get bh
1562        a5 <- get bh
1563        return (IfaceVectInfo a1 a2 a3 a4 a5)
1564
1565instance Binary IfaceTrustInfo where
1566    put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
1567    get bh = getByte bh >>= (return . numToTrustInfo)
Note: See TracBrowser for help on using the browser.