Commit 5d7173f9 authored by batterseapower's avatar batterseapower

Change the way IfExtName is serialized so (most) wired-in names get special representation

This lets IfaceType be dumber, with fewer special cases, because deserialization for more
wired-in names will work. Once we have polymorphic kinds we will be able to replace IfaceTyCon
with a simple IfExtName.
parent e2496a81
...@@ -87,9 +87,7 @@ import FastTypes ...@@ -87,9 +87,7 @@ import FastTypes
import FastString import FastString
import Outputable import Outputable
import Data.Array
import Data.Data import Data.Data
import Data.Word ( Word32 )
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -416,9 +414,9 @@ instance Binary Name where ...@@ -416,9 +414,9 @@ instance Binary Name where
case getUserData bh of case getUserData bh of
UserData{ ud_put_name = put_name } -> put_name bh name UserData{ ud_put_name = put_name } -> put_name bh name
get bh = do get bh =
i <- get bh case getUserData bh of
return $! (ud_symtab (getUserData bh) ! fromIntegral (i::Word32)) UserData { ud_get_name = get_name } -> get_name bh
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -27,7 +27,8 @@ module Unique ( ...@@ -27,7 +27,8 @@ module Unique (
pprUnique, pprUnique,
mkUniqueGrimily, -- Used in UniqSupply only! mkUniqueGrimily, -- Used in UniqSupply only!
getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only! getKey, getKeyFastInt, -- Used in Var, UniqFM, Name only!
mkUnique, unpkUnique, -- Used in BinIface only
incrUnique, -- Used for renumbering incrUnique, -- Used for renumbering
deriveUnique, -- Ditto deriveUnique, -- Ditto
......
...@@ -629,7 +629,7 @@ lintInCo co ...@@ -629,7 +629,7 @@ lintInCo co
lintKind :: Kind -> LintM () lintKind :: Kind -> LintM ()
-- Check well-formedness of kinds: *, *->*, etc -- Check well-formedness of kinds: *, *->*, etc
lintKind (TyConApp tc []) lintKind (TyConApp tc [])
| getUnique tc `elem` kindKeys | tyConKind tc `eqKind` tySuperKind
= return () = return ()
lintKind (FunTy k1 k2) lintKind (FunTy k1 k2)
= lintKind k1 >> lintKind k2 = lintKind k1 >> lintKind k2
......
...@@ -7,12 +7,18 @@ ...@@ -7,12 +7,18 @@
-- --
-- Binary interface file support. -- Binary interface file support.
module BinIface ( writeBinIface, readBinIface, module BinIface ( writeBinIface, readBinIface, getSymtabName, getDictFastString,
CheckHiWay(..), TraceBinIFaceReading(..) ) where CheckHiWay(..), TraceBinIFaceReading(..) ) where
#include "HsVersions.h" #include "HsVersions.h"
import TcRnMonad import TcRnMonad
import TyCon (TyCon, tyConName, tupleTyConSort, tupleTyConArity, isTupleTyCon, tyConIP_maybe)
import DataCon (dataConName, dataConWorkId, dataConTyCon)
import IParam (ipFastString, ipTyConName)
import PrelInfo (wiredInThings, basicKnownKeyNames)
import Id (idName, isDataConWorkId_maybe)
import TysWiredIn
import IfaceEnv import IfaceEnv
import HscTypes import HscTypes
import BasicTypes import BasicTypes
...@@ -39,6 +45,8 @@ import Outputable ...@@ -39,6 +45,8 @@ import Outputable
import FastString import FastString
import Constants import Constants
import Data.Bits
import Data.Char
import Data.List import Data.List
import Data.Word import Data.Word
import Data.Array import Data.Array
...@@ -57,14 +65,14 @@ data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading ...@@ -57,14 +65,14 @@ data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
-> TcRnIf a b ModIface -> TcRnIf a b ModIface
readBinIface checkHiWay traceBinIFaceReading hi_path = do readBinIface checkHiWay traceBinIFaceReading hi_path = do
update_nc <- mkNameCacheUpdater ncu <- mkNameCacheUpdater
dflags <- getDOpts dflags <- getDOpts
liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
-> NameCacheUpdater (Array Int Name) -> NameCacheUpdater
-> IO ModIface -> IO ModIface
readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
let printer :: SDoc -> IO () let printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
...@@ -126,18 +134,22 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do ...@@ -126,18 +134,22 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
seekBin bh data_p -- Back to where we were before seekBin bh data_p -- Back to where we were before
-- Initialise the user-data field of bh -- Initialise the user-data field of bh
ud <- newReadState dict bh <- do
bh <- return (setUserData bh ud) bh <- return $ setUserData bh $ newReadState (error "getSymtabName")
(getDictFastString dict)
symtab_p <- Binary.get bh -- Get the symtab ptr
data_p <- tellBin bh -- Remember where we are now symtab_p <- Binary.get bh -- Get the symtab ptr
seekBin bh symtab_p data_p <- tellBin bh -- Remember where we are now
symtab <- getSymbolTable bh update_nc seekBin bh symtab_p
seekBin bh data_p -- Back to where we were before symtab <- getSymbolTable bh ncu
let ud = getUserData bh seekBin bh data_p -- Back to where we were before
bh <- return $! setUserData bh ud{ud_symtab = symtab}
iface <- get bh -- It is only now that we know how to get a Name
return iface return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
(getDictFastString dict)
-- Read the interface file
get bh
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
...@@ -178,10 +190,10 @@ writeBinIface dflags hi_path mod_iface = do ...@@ -178,10 +190,10 @@ writeBinIface dflags hi_path mod_iface = do
let bin_dict = BinDictionary { let bin_dict = BinDictionary {
bin_dict_next = dict_next_ref, bin_dict_next = dict_next_ref,
bin_dict_map = dict_map_ref } bin_dict_map = dict_map_ref }
ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
-- Put the main thing, -- Put the main thing,
bh <- return $ setUserData bh ud bh <- return $ setUserData bh $ newWriteState (putName bin_dict bin_symtab)
(putFastString bin_dict)
put_ bh mod_iface put_ bh mod_iface
-- Write the symtab pointer at the fornt of the file -- Write the symtab pointer at the fornt of the file
...@@ -236,12 +248,12 @@ putSymbolTable bh next_off symtab = do ...@@ -236,12 +248,12 @@ putSymbolTable bh next_off symtab = do
let names = elems (array (0,next_off-1) (eltsUFM symtab)) let names = elems (array (0,next_off-1) (eltsUFM symtab))
mapM_ (\n -> serialiseName bh n symtab) names mapM_ (\n -> serialiseName bh n symtab) names
getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name) getSymbolTable :: BinHandle -> NameCacheUpdater
-> IO (Array Int Name) -> IO SymbolTable
getSymbolTable bh update_namecache = do getSymbolTable bh ncu = do
sz <- get bh sz <- get bh
od_names <- sequence (replicate sz (get bh)) od_names <- sequence (replicate sz (get bh))
update_namecache $ \namecache -> updateNameCache ncu $ \namecache ->
let let
arr = listArray (0,sz-1) names arr = listArray (0,sz-1) names
(namecache', names) = (namecache', names) =
...@@ -277,21 +289,108 @@ serialiseName bh name _ = do ...@@ -277,21 +289,108 @@ serialiseName bh name _ = do
put_ bh (modulePackageId mod, moduleName mod, nameOccName name) put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
putName :: BinSymbolTable -> BinHandle -> Name -> IO () -- Note [Symbol table representation of names]
putName BinSymbolTable{ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
bin_symtab_map = symtab_map_ref, --
bin_symtab_next = symtab_next } bh name -- An occurrence of a name in an interface file is serialized as a single 32-bit word.
= do -- The format of this word is:
symtab_map <- readIORef symtab_map_ref -- 00xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
case lookupUFM symtab_map name of -- A normal name. x is an index into the symbol table
Just (off,_) -> put_ bh (fromIntegral off :: Word32) -- 01xxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyy
Nothing -> do -- A known-key name. x is the Unique's Char, y is the int part
off <- readFastMutInt symtab_next -- 10xxyyzzzzzzzzzzzzzzzzzzzzzzzzzzzz
writeFastMutInt symtab_next (off+1) -- A tuple name:
writeIORef symtab_map_ref -- x is the tuple sort (00b ==> boxed, 01b ==> unboxed, 10b ==> constraint)
$! addToUFM symtab_map name (off,name) -- y is the thing (00b ==> tycon, 01b ==> datacon, 10b ==> datacon worker)
put_ bh (fromIntegral off :: Word32) -- z is the arity
-- 11xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
-- An implicit parameter TyCon name. x is an index into the FastString *dictionary*
--
-- Note that we have to have special representation for tuples and IP TyCons because they
-- form an "infinite" family and hence are not recorded explicitly in wiredInTyThings or
-- basicKnownKeyNames.
knownKeyNamesMap :: UniqFM Name
knownKeyNamesMap = listToUFM_Directly [(nameUnique n, n) | n <- knownKeyNames]
where
knownKeyNames :: [Name]
knownKeyNames = map getName wiredInThings
++ basicKnownKeyNames
-- See Note [Symbol table representation of names]
putName :: BinDictionary -> BinSymbolTable -> BinHandle -> Name -> IO ()
putName dict BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next } bh name
| name `elemUFM` knownKeyNamesMap
, let (c, u) = unpkUnique (nameUnique name) -- INVARIANT: (ord c) fits in 8 bits
= -- ASSERT(u < 2^(22 :: Int))
put_ bh (0x40000000 .|. (fromIntegral (ord c) `shiftL` 22) .|. (fromIntegral u :: Word32))
| otherwise
= case wiredInNameTyThing_maybe name of
Just (ATyCon tc)
| isTupleTyCon tc -> putTupleName_ bh tc 0
| Just ip <- tyConIP_maybe tc -> do
off <- allocateFastString dict (ipFastString ip)
-- MASSERT(off < 2^(30 :: Int))
put_ bh (0xC0000000 .|. off)
Just (ADataCon dc)
| let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 1
Just (AnId x)
| Just dc <- isDataConWorkId_maybe x, let tc = dataConTyCon dc, isTupleTyCon tc -> putTupleName_ bh tc 2
_ -> do
symtab_map <- readIORef symtab_map_ref
case lookupUFM symtab_map name of
Just (off,_) -> put_ bh (fromIntegral off :: Word32)
Nothing -> do
off <- readFastMutInt symtab_next
-- MASSERT(off < 2^(30 :: Int))
writeFastMutInt symtab_next (off+1)
writeIORef symtab_map_ref
$! addToUFM symtab_map name (off,name)
put_ bh (fromIntegral off :: Word32)
putTupleName_ :: BinHandle -> TyCon -> Word32 -> IO ()
putTupleName_ bh tc thing_tag
= -- ASSERT(arity < 2^(30 :: Int))
put_ bh (0x80000000 .|. (sort_tag `shiftL` 28) .|. (thing_tag `shiftL` 26) .|. arity)
where
arity = fromIntegral (tupleTyConArity tc)
sort_tag = case tupleTyConSort tc of
BoxedTuple -> 0
UnboxedTuple -> 1
ConstraintTuple -> 2
-- See Note [Symbol table representation of names]
getSymtabName :: NameCacheUpdater
-> Dictionary -> SymbolTable
-> BinHandle -> IO Name
getSymtabName ncu dict symtab bh = do
i <- get bh
case i .&. 0xC0000000 of
0x00000000 -> return $! symtab ! fromIntegral (i ::  Word32)
0x40000000 -> return $! case lookupUFM_Directly knownKeyNamesMap (mkUnique tag ix) of
Nothing -> pprPanic "getSymtabName:unknown known-key unique" (ppr i)
Just n -> n
where tag = chr (fromIntegral ((i .&. 0x3FC00000) `shiftR` 22))
ix = fromIntegral i .&. 0x003FFFFF
0x80000000 -> return $! case thing_tag of
0 -> tyConName (tupleTyCon sort arity)
1 -> dataConName dc
2 -> idName (dataConWorkId dc)
_ -> pprPanic "getSymtabName:unknown tuple thing" (ppr i)
where
dc = tupleCon sort arity
sort = case (i .&. 0x30000000) `shiftR` 28 of
0 -> BoxedTuple
1 -> UnboxedTuple
2 -> ConstraintTuple
_ -> pprPanic "getSymtabName:unknown tuple sort" (ppr i)
thing_tag = (i .&. 0x0CFFFFFF) `shiftR` 26
arity = fromIntegral (i .&. 0x03FFFFFF)
0xC0000000 -> liftM ipTyConName $ updateNameCache ncu $ flip allocateIPName (dict ! fromIntegral (i .&. 0x3FFFFFFF))
_ -> pprPanic "getSymtabName:unknown name tag" (ppr i)
data BinSymbolTable = BinSymbolTable { data BinSymbolTable = BinSymbolTable {
bin_symtab_next :: !FastMutInt, -- The next index to use bin_symtab_next :: !FastMutInt, -- The next index to use
...@@ -301,19 +400,25 @@ data BinSymbolTable = BinSymbolTable { ...@@ -301,19 +400,25 @@ data BinSymbolTable = BinSymbolTable {
putFastString :: BinDictionary -> BinHandle -> FastString -> IO () putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
putFastString BinDictionary { bin_dict_next = j_r, putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
bin_dict_map = out_r} bh f
= do allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary { bin_dict_next = j_r,
bin_dict_map = out_r} f = do
out <- readIORef out_r out <- readIORef out_r
let uniq = getUnique f let uniq = getUnique f
case lookupUFM out uniq of case lookupUFM out uniq of
Just (j, _) -> put_ bh (fromIntegral j :: Word32) Just (j, _) -> return (fromIntegral j :: Word32)
Nothing -> do Nothing -> do
j <- readFastMutInt j_r j <- readFastMutInt j_r
put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1) writeFastMutInt j_r (j + 1)
writeIORef out_r $! addToUFM out uniq (j, f) writeIORef out_r $! addToUFM out uniq (j, f)
return (fromIntegral j :: Word32)
getDictFastString :: Dictionary -> BinHandle -> IO FastString
getDictFastString dict bh = do
j <- get bh
return $! (dict ! fromIntegral (j :: Word32))
data BinDictionary = BinDictionary { data BinDictionary = BinDictionary {
bin_dict_next :: !FastMutInt, -- The next index to use bin_dict_next :: !FastMutInt, -- The next index to use
...@@ -892,27 +997,11 @@ instance Binary IfaceType where ...@@ -892,27 +997,11 @@ instance Binary IfaceType where
put_ bh ah put_ bh ah
-- Simple compression for common cases of TyConApp -- Simple compression for common cases of TyConApp
put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6 put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 4; put_ bh k }
put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7 put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 5; put_ bh tc; put_ bh tys }
put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8 put_ bh (IfaceTyConApp tc tys) = do { putByte bh 6; put_ bh tc; put_ bh tys }
put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
-- Unit tuple and pairs put_ bh (IfaceCoConApp cc tys) = do { putByte bh 7; put_ bh cc; put_ bh tys }
put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 0) []) = putByte bh 10
put_ bh (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) = do { putByte bh 11; put_ bh t1; put_ bh t2 }
-- Kind cases
put_ bh (IfaceTyConApp IfaceLiftedTypeKindTc []) = putByte bh 12
put_ bh (IfaceTyConApp IfaceOpenTypeKindTc []) = putByte bh 13
put_ bh (IfaceTyConApp IfaceUnliftedTypeKindTc []) = putByte bh 14
put_ bh (IfaceTyConApp IfaceUbxTupleKindTc []) = putByte bh 15
put_ bh (IfaceTyConApp IfaceArgTypeKindTc []) = putByte bh 16
put_ bh (IfaceTyConApp IfaceConstraintKindTc []) = putByte bh 21
put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k }
-- Generic cases
put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys }
put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys }
get bh = do get bh = do
h <- getByte bh h <- getByte bh
...@@ -928,62 +1017,20 @@ instance Binary IfaceType where ...@@ -928,62 +1017,20 @@ instance Binary IfaceType where
3 -> do ag <- get bh 3 -> do ag <- get bh
ah <- get bh ah <- get bh
return (IfaceFunTy ag ah) return (IfaceFunTy ag ah)
4 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
-- Now the special cases for TyConApp 5 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
6 -> return (IfaceTyConApp IfaceIntTc []) 6 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
7 -> return (IfaceTyConApp IfaceCharTc []) _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
8 -> return (IfaceTyConApp IfaceBoolTc [])
9 -> do { ty <- get bh; return (IfaceTyConApp IfaceListTc [ty]) }
10 -> return (IfaceTyConApp (IfaceTupTc BoxedTuple 0) [])
11 -> do { t1 <- get bh; t2 <- get bh; return (IfaceTyConApp (IfaceTupTc BoxedTuple 2) [t1,t2]) }
12 -> return (IfaceTyConApp IfaceLiftedTypeKindTc [])
13 -> return (IfaceTyConApp IfaceOpenTypeKindTc [])
14 -> return (IfaceTyConApp IfaceUnliftedTypeKindTc [])
15 -> return (IfaceTyConApp IfaceUbxTupleKindTc [])
16 -> return (IfaceTyConApp IfaceArgTypeKindTc [])
21 -> return (IfaceTyConApp IfaceConstraintKindTc [])
17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
_ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
instance Binary IfaceTyCon where instance Binary IfaceTyCon where
-- Int,Char,Bool can't show up here because they can't not be saturated put_ bh (IfaceTc ext) = do { putByte bh 1; put_ bh ext }
put_ bh IfaceIntTc = putByte bh 1 put_ bh (IfaceAnyTc k) = do { putByte bh 2; put_ bh k }
put_ bh IfaceBoolTc = putByte bh 2
put_ bh IfaceCharTc = putByte bh 3
put_ bh IfaceListTc = putByte bh 4
put_ bh IfacePArrTc = putByte bh 5
put_ bh IfaceLiftedTypeKindTc = putByte bh 6
put_ bh IfaceOpenTypeKindTc = putByte bh 7
put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
put_ bh IfaceUbxTupleKindTc = putByte bh 9
put_ bh IfaceArgTypeKindTc = putByte bh 10
put_ bh IfaceConstraintKindTc = putByte bh 15
put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext }
put_ bh (IfaceIPTc n) = do { putByte bh 13; put_ bh n }
put_ bh (IfaceAnyTc k) = do { putByte bh 14; put_ bh k }
get bh = do get bh = do
h <- getByte bh h <- getByte bh
case h of case h of
1 -> return IfaceIntTc 1 -> do { ext <- get bh; return (IfaceTc ext) }
2 -> return IfaceBoolTc _ -> do { k <- get bh; return (IfaceAnyTc k) }
3 -> return IfaceCharTc
4 -> return IfaceListTc
5 -> return IfacePArrTc
6 -> return IfaceLiftedTypeKindTc
7 -> return IfaceOpenTypeKindTc
8 -> return IfaceUnliftedTypeKindTc
9 -> return IfaceUbxTupleKindTc
10 -> return IfaceArgTypeKindTc
15 -> return IfaceConstraintKindTc
11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
12 -> do { ext <- get bh; return (IfaceTc ext) }
13 -> do { n <- get bh; return (IfaceIPTc n) }
_ -> do { k <- get bh; return (IfaceAnyTc k) }
instance Binary IfaceCoCon where instance Binary IfaceCoCon where
put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n }
...@@ -1064,10 +1111,6 @@ instance Binary IfaceExpr where ...@@ -1064,10 +1111,6 @@ instance Binary IfaceExpr where
putByte bh 13 putByte bh 13
put_ bh m put_ bh m
put_ bh ix put_ bh ix
put_ bh (IfaceTupId aa ab) = do
putByte bh 14
put_ bh aa
put_ bh ab
get bh = do get bh = do
h <- getByte bh h <- getByte bh
case h of case h of
...@@ -1109,9 +1152,6 @@ instance Binary IfaceExpr where ...@@ -1109,9 +1152,6 @@ instance Binary IfaceExpr where
13 -> do m <- get bh 13 -> do m <- get bh
ix <- get bh ix <- get bh
return (IfaceTick m ix) return (IfaceTick m ix)
14 -> do aa <- get bh
ab <- get bh
return (IfaceTupId aa ab)
_ -> panic ("get IfaceExpr " ++ show h) _ -> panic ("get IfaceExpr " ++ show h)
instance Binary IfaceConAlt where instance Binary IfaceConAlt where
...@@ -1120,11 +1160,8 @@ instance Binary IfaceConAlt where ...@@ -1120,11 +1160,8 @@ instance Binary IfaceConAlt where
put_ bh (IfaceDataAlt aa) = do put_ bh (IfaceDataAlt aa) = do
putByte bh 1 putByte bh 1
put_ bh aa put_ bh aa
put_ bh (IfaceTupleAlt ab) = do
putByte bh 2
put_ bh ab
put_ bh (IfaceLitAlt ac) = do put_ bh (IfaceLitAlt ac) = do
putByte bh 3 putByte bh 2
put_ bh ac put_ bh ac
get bh = do get bh = do
h <- getByte bh h <- getByte bh
...@@ -1132,8 +1169,6 @@ instance Binary IfaceConAlt where ...@@ -1132,8 +1169,6 @@ instance Binary IfaceConAlt where
0 -> do return IfaceDefault 0 -> do return IfaceDefault
1 -> do aa <- get bh 1 -> do aa <- get bh
return (IfaceDataAlt aa) return (IfaceDataAlt aa)
2 -> do ab <- get bh
return (IfaceTupleAlt ab)
_ -> do ac <- get bh _ -> do ac <- get bh
return (IfaceLitAlt ac) return (IfaceLitAlt ac)
......
...@@ -13,8 +13,8 @@ module IfaceEnv ( ...@@ -13,8 +13,8 @@ module IfaceEnv (
ifaceExportNames, ifaceExportNames,
-- Name-cache stuff -- Name-cache stuff
allocateGlobalBinder, initNameCache, updNameCache, allocateGlobalBinder, allocateIPName, initNameCache, updNameCache,
getNameCache, mkNameCacheUpdater, NameCacheUpdater getNameCache, mkNameCacheUpdater, NameCacheUpdater(..)
) where ) where
#include "HsVersions.h" #include "HsVersions.h"
...@@ -160,19 +160,20 @@ lookupOrig mod occ ...@@ -160,19 +160,20 @@ lookupOrig mod occ
in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) in (name_cache{ nsUniqs = us, nsNames = new_cache }, name)
}}} }}}
allocateIPName :: NameCache -> FastString -> (NameCache, IPName Name)
allocateIPName name_cache ip = case Map.lookup ip ipcache of
Just name_ip -> (name_cache, name_ip)
Nothing -> (new_ns, name_ip)
where
(us_here, us') = splitUniqSupply (nsUniqs name_cache)
tycon_u:datacon_u:dc_wrk_u:co_ax_u:_ = uniqsFromSupply us_here
name_ip = mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u
new_ipcache = Map.insert ip name_ip ipcache
new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache}
where ipcache = nsIPs name_cache
newIPName :: FastString -> TcRnIf m n (IPName Name) newIPName :: FastString -> TcRnIf m n (IPName Name)
newIPName ip = newIPName ip = updNameCache $ flip allocateIPName ip
updNameCache $ \name_cache ->
let ipcache = nsIPs name_cache
in case Map.lookup ip ipcache of
Just name_ip -> (name_cache, name_ip)
Nothing -> (new_ns, name_ip)
where
(us_here, us') = splitUniqSupply (nsUniqs name_cache)
tycon_u:datacon_u:dc_wrk_u:co_ax_u:_ = uniqsFromSupply us_here
name_ip = mkIPName ip tycon_u datacon_u dc_wrk_u co_ax_u
new_ipcache = Map.insert ip name_ip ipcache
new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache}
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -225,16 +226,16 @@ updNameCache upd_fn = do ...@@ -225,16 +226,16 @@ updNameCache upd_fn = do
-- | A function that atomically updates the name cache given a modifier -- | A function that atomically updates the name cache given a modifier
-- function. The second result of the modifier function will be the result -- function. The second result of the modifier function will be the result
-- of the IO action. -- of the IO action.
type NameCacheUpdater c = (NameCache -> (NameCache, c)) -> IO c data NameCacheUpdater = NCU { updateNameCache :: forall c. (NameCache -> (NameCache, c)) -> IO c }
-- | Return a function to atomically update the name cache. -- | Return a function to atomically update the name cache.
mkNameCacheUpdater :: TcRnIf a b (NameCacheUpdater c) mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do mkNameCacheUpdater = do
nc_var <- hsc_NC `fmap` getTopEnv nc_var <- hsc_NC `fmap` getTopEnv
let update_nc f = do r <- atomicModifyIORef nc_var f let update_nc f = do r <- atomicModifyIORef nc_var f
_ <- evaluate =<< readIORef nc_var _ <- evaluate =<< readIORef nc_var
return r