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
import FastString
import Outputable
import Data.Array
import Data.Data
import Data.Word ( Word32 )
\end{code}
%************************************************************************
......@@ -416,9 +414,9 @@ instance Binary Name where
case getUserData bh of
UserData{ ud_put_name = put_name } -> put_name bh name
get bh = do
i <- get bh
return $! (ud_symtab (getUserData bh) ! fromIntegral (i::Word32))
get bh =
case getUserData bh of
UserData { ud_get_name = get_name } -> get_name bh
\end{code}
%************************************************************************
......
......@@ -27,7 +27,8 @@ module Unique (
pprUnique,
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
deriveUnique, -- Ditto
......
......@@ -629,7 +629,7 @@ lintInCo co
lintKind :: Kind -> LintM ()
-- Check well-formedness of kinds: *, *->*, etc
lintKind (TyConApp tc [])
| getUnique tc `elem` kindKeys
| tyConKind tc `eqKind` tySuperKind
= return ()
lintKind (FunTy k1 k2)
= lintKind k1 >> lintKind k2
......
......@@ -7,12 +7,18 @@
--
-- Binary interface file support.
module BinIface ( writeBinIface, readBinIface,
module BinIface ( writeBinIface, readBinIface, getSymtabName, getDictFastString,
CheckHiWay(..), TraceBinIFaceReading(..) ) where
#include "HsVersions.h"
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 HscTypes
import BasicTypes
......@@ -39,6 +45,8 @@ import Outputable
import FastString
import Constants
import Data.Bits
import Data.Char
import Data.List
import Data.Word
import Data.Array
......@@ -57,14 +65,14 @@ data TraceBinIFaceReading = TraceBinIFaceReading | QuietBinIFaceReading
readBinIface :: CheckHiWay -> TraceBinIFaceReading -> FilePath
-> TcRnIf a b ModIface
readBinIface checkHiWay traceBinIFaceReading hi_path = do
update_nc <- mkNameCacheUpdater
ncu <- mkNameCacheUpdater
dflags <- getDOpts
liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc
liftIO $ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu
readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
-> NameCacheUpdater (Array Int Name)
-> NameCacheUpdater
-> IO ModIface
readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
let printer :: SDoc -> IO ()
printer = case traceBinIFaceReading of
TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
......@@ -126,18 +134,22 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
seekBin bh data_p -- Back to where we were before
-- Initialise the user-data field of bh
ud <- newReadState dict
bh <- return (setUserData bh ud)
symtab_p <- Binary.get bh -- Get the symtab ptr
data_p <- tellBin bh -- Remember where we are now
seekBin bh symtab_p
symtab <- getSymbolTable bh update_nc
seekBin bh data_p -- Back to where we were before
let ud = getUserData bh
bh <- return $! setUserData bh ud{ud_symtab = symtab}
iface <- get bh
return iface
bh <- do
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
seekBin bh symtab_p
symtab <- getSymbolTable bh ncu
seekBin bh data_p -- Back to where we were before
-- It is only now that we know how to get a Name
return $ setUserData bh $ newReadState (getSymtabName ncu dict symtab)
(getDictFastString dict)
-- Read the interface file
get bh
writeBinIface :: DynFlags -> FilePath -> ModIface -> IO ()
......@@ -178,10 +190,10 @@ writeBinIface dflags hi_path mod_iface = do
let bin_dict = BinDictionary {
bin_dict_next = dict_next_ref,
bin_dict_map = dict_map_ref }
ud <- newWriteState (putName bin_symtab) (putFastString bin_dict)
-- 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
-- Write the symtab pointer at the fornt of the file
......@@ -236,12 +248,12 @@ putSymbolTable bh next_off symtab = do
let names = elems (array (0,next_off-1) (eltsUFM symtab))
mapM_ (\n -> serialiseName bh n symtab) names
getSymbolTable :: BinHandle -> NameCacheUpdater (Array Int Name)
-> IO (Array Int Name)
getSymbolTable bh update_namecache = do
getSymbolTable :: BinHandle -> NameCacheUpdater
-> IO SymbolTable
getSymbolTable bh ncu = do
sz <- get bh
od_names <- sequence (replicate sz (get bh))
update_namecache $ \namecache ->
updateNameCache ncu $ \namecache ->
let
arr = listArray (0,sz-1) names
(namecache', names) =
......@@ -277,21 +289,108 @@ serialiseName bh name _ = do
put_ bh (modulePackageId mod, moduleName mod, nameOccName name)
putName :: BinSymbolTable -> BinHandle -> Name -> IO ()
putName BinSymbolTable{
bin_symtab_map = symtab_map_ref,
bin_symtab_next = symtab_next } bh name
= 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
writeFastMutInt symtab_next (off+1)
writeIORef symtab_map_ref
$! addToUFM symtab_map name (off,name)
put_ bh (fromIntegral off :: Word32)
-- Note [Symbol table representation of names]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
-- An occurrence of a name in an interface file is serialized as a single 32-bit word.
-- The format of this word is:
-- 00xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxx
-- A normal name. x is an index into the symbol table
-- 01xxxxxxxxyyyyyyyyyyyyyyyyyyyyyyyy
-- A known-key name. x is the Unique's Char, y is the int part
-- 10xxyyzzzzzzzzzzzzzzzzzzzzzzzzzzzz
-- A tuple name:
-- x is the tuple sort (00b ==> boxed, 01b ==> unboxed, 10b ==> constraint)
-- y is the thing (00b ==> tycon, 01b ==> datacon, 10b ==> datacon worker)
-- 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 {
bin_symtab_next :: !FastMutInt, -- The next index to use
......@@ -301,19 +400,25 @@ data BinSymbolTable = BinSymbolTable {
putFastString :: BinDictionary -> BinHandle -> FastString -> IO ()
putFastString BinDictionary { bin_dict_next = j_r,
bin_dict_map = out_r} bh f
= do
putFastString dict bh fs = allocateFastString dict fs >>= put_ bh
allocateFastString :: BinDictionary -> FastString -> IO Word32
allocateFastString BinDictionary { bin_dict_next = j_r,
bin_dict_map = out_r} f = do
out <- readIORef out_r
let uniq = getUnique f
case lookupUFM out uniq of
Just (j, _) -> put_ bh (fromIntegral j :: Word32)
Just (j, _) -> return (fromIntegral j :: Word32)
Nothing -> do
j <- readFastMutInt j_r
put_ bh (fromIntegral j :: Word32)
writeFastMutInt j_r (j + 1)
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 {
bin_dict_next :: !FastMutInt, -- The next index to use
......@@ -892,27 +997,11 @@ instance Binary IfaceType where
put_ bh ah
-- Simple compression for common cases of TyConApp
put_ bh (IfaceTyConApp IfaceIntTc []) = putByte bh 6
put_ bh (IfaceTyConApp IfaceCharTc []) = putByte bh 7
put_ bh (IfaceTyConApp IfaceBoolTc []) = putByte bh 8
put_ bh (IfaceTyConApp IfaceListTc [ty]) = do { putByte bh 9; put_ bh ty }
-- Unit tuple and pairs
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 }
put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 4; put_ bh k }
put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 5; put_ bh tc; put_ bh tys }
put_ bh (IfaceTyConApp tc tys) = do { putByte bh 6; put_ bh tc; put_ bh tys }
put_ bh (IfaceCoConApp cc tys) = do { putByte bh 7; put_ bh cc; put_ bh tys }
get bh = do
h <- getByte bh
......@@ -928,62 +1017,20 @@ instance Binary IfaceType where
3 -> do ag <- get bh
ah <- get bh
return (IfaceFunTy ag ah)
-- Now the special cases for TyConApp
6 -> return (IfaceTyConApp IfaceIntTc [])
7 -> return (IfaceTyConApp IfaceCharTc [])
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) }
4 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
5 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
6 -> 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
-- Int,Char,Bool can't show up here because they can't not be saturated
put_ bh IfaceIntTc = putByte bh 1
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 }
put_ bh (IfaceTc ext) = do { putByte bh 1; put_ bh ext }
put_ bh (IfaceAnyTc k) = do { putByte bh 2; put_ bh k }
get bh = do
h <- getByte bh
case h of
1 -> return IfaceIntTc
2 -> return IfaceBoolTc
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) }
1 -> do { ext <- get bh; return (IfaceTc ext) }
_ -> do { k <- get bh; return (IfaceAnyTc k) }
instance Binary IfaceCoCon where
put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n }
......@@ -1064,10 +1111,6 @@ instance Binary IfaceExpr where
putByte bh 13
put_ bh m
put_ bh ix
put_ bh (IfaceTupId aa ab) = do
putByte bh 14
put_ bh aa
put_ bh ab
get bh = do
h <- getByte bh
case h of
......@@ -1109,9 +1152,6 @@ instance Binary IfaceExpr where
13 -> do m <- get bh
ix <- get bh
return (IfaceTick m ix)
14 -> do aa <- get bh
ab <- get bh
return (IfaceTupId aa ab)
_ -> panic ("get IfaceExpr " ++ show h)
instance Binary IfaceConAlt where
......@@ -1120,11 +1160,8 @@ instance Binary IfaceConAlt where
put_ bh (IfaceDataAlt aa) = do
putByte bh 1
put_ bh aa
put_ bh (IfaceTupleAlt ab) = do
putByte bh 2
put_ bh ab
put_ bh (IfaceLitAlt ac) = do
putByte bh 3
putByte bh 2
put_ bh ac
get bh = do
h <- getByte bh
......@@ -1132,8 +1169,6 @@ instance Binary IfaceConAlt where
0 -> do return IfaceDefault
1 -> do aa <- get bh
return (IfaceDataAlt aa)
2 -> do ab <- get bh
return (IfaceTupleAlt ab)
_ -> do ac <- get bh
return (IfaceLitAlt ac)
......
......@@ -13,8 +13,8 @@ module IfaceEnv (
ifaceExportNames,
-- Name-cache stuff
allocateGlobalBinder, initNameCache, updNameCache,
getNameCache, mkNameCacheUpdater, NameCacheUpdater
allocateGlobalBinder, allocateIPName, initNameCache, updNameCache,
getNameCache, mkNameCacheUpdater, NameCacheUpdater(..)
) where
#include "HsVersions.h"
......@@ -160,19 +160,20 @@ lookupOrig mod occ
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 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}
newIPName ip = updNameCache $ flip allocateIPName ip
\end{code}
%************************************************************************
......@@ -225,16 +226,16 @@ updNameCache upd_fn = do
-- | A function that atomically updates the name cache given a modifier
-- function. The second result of the modifier function will be the result
-- 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.
mkNameCacheUpdater :: TcRnIf a b (NameCacheUpdater c)
mkNameCacheUpdater :: TcRnIf a b NameCacheUpdater
mkNameCacheUpdater = do
nc_var <- hsc_NC `fmap` getTopEnv
let update_nc f = do r <- atomicModifyIORef nc_var f
_ <- evaluate =<< readIORef nc_var
return r
return update_nc
return (NCU update_nc)
\end{code}
......
......@@ -236,7 +236,6 @@ data IfaceUnfolding
data IfaceExpr
= IfaceLcl IfLclName
| IfaceExt IfExtName
| IfaceTupId TupleSort Arity
| IfaceType IfaceType
| IfaceCo IfaceType -- We re-use IfaceType for coercions
| IfaceTuple TupleSort [IfaceExpr] -- Saturated; type arguments omitted
......@@ -260,7 +259,6 @@ type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr)
data IfaceConAlt = IfaceDefault
| IfaceDataAlt IfExtName
| IfaceTupleAlt TupleSort
| IfaceLitAlt Literal
data IfaceBinding
......@@ -573,7 +571,6 @@ pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc
pprIfaceExpr _ (IfaceLcl v) = ppr v
pprIfaceExpr _ (IfaceExt v) = ppr v
pprIfaceExpr _ (IfaceTupId c n) = tupleParens c (hcat (replicate (n - 1) (char ',')))
pprIfaceExpr _ (IfaceLit l) = ppr l
pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix)
......@@ -628,8 +625,7 @@ ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs,
arrow <+> pprIfaceExpr noParens rhs]
ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc
ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs)
ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
ppr_con_bs con bs = ppr con <+> hsep (map ppr bs)
ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc
ppr_bind (IfLetBndr b ty info, rhs)
......@@ -653,8 +649,6 @@ instance Outputable IfaceConAlt where
ppr IfaceDefault = text "DEFAULT"
ppr (IfaceLitAlt l) = ppr l
ppr (IfaceDataAlt d) = ppr d
ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt"
-- IfaceTupleAlt is handled by the case-alternative printer
------------------
instance Outputable IfaceIdDetails where
......@@ -817,7 +811,6 @@ freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs
freeNamesIfExpr :: IfaceExpr -> NameSet
freeNamesIfExpr (IfaceExt v) = unitNameSet v
freeNamesIfExpr (IfaceTupId _ _) = emptyNameSet
freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty
freeNamesIfExpr (IfaceCo co) = freeNamesIfType co
......
......@@ -80,19 +80,12 @@ data IfaceType -- A kind of universal type, used for types, kinds, and coerci
type IfacePredType = IfaceType
type IfaceContext = [IfacePredType]
data IfaceTyCon -- Encodes type consructors, kind constructors
-- coercion constructors, the lot
= IfaceTc IfExtName -- The common case
| IfaceIntTc | IfaceBoolTc | IfaceCharTc
| IfaceListTc | IfacePArrTc
| IfaceTupTc TupleSort Arity
| IfaceIPTc IfIPName -- Used for implicit parameter TyCons
| IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
-- other than 'Any :: *' itself
-- Kind constructors
| IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
| IfaceUbxTupleKindTc | IfaceArgTypeKindTc | IfaceConstraintKindTc
data IfaceTyCon -- Encodes type consructors, kind constructors
-- coercion constructors, the lot
= IfaceTc IfExtName -- The common case
| IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
-- other than 'Any :: *' itself
-- XXX: remove this case after Any becomes kind-polymorphic
-- Coercion constructors
data IfaceCoCon
......@@ -103,23 +96,9 @@ data IfaceCoCon
| IfaceNthCo Int
ifaceTyConName :: IfaceTyCon -> Name
ifaceTyConName IfaceIntTc = intTyConName
ifaceTyConName IfaceBoolTc = boolTyConName
ifaceTyConName IfaceCharTc = charTyConName
ifaceTyConName IfaceListTc = listTyConName
ifaceTyConName IfacePArrTc = parrTyConName
ifaceTyConName (IfaceTupTc bx ar) = getName (tupleTyCon bx ar)
ifaceTyConName IfaceLiftedTypeKindTc = liftedTypeKindTyConName
ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName
ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName
ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName
ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName
ifaceTyConName IfaceConstraintKindTc = constraintKindTyConName
ifaceTyConName (IfaceTc ext) = ext
ifaceTyConName (IfaceIPTc n) = pprPanic "ifaceTyConName:IPTc" (ppr n)
ifaceTyConName (IfaceAnyTc k) = pprPanic "ifaceTyConName:AnyTc" (ppr k)
-- Note [The Name of an IfaceAnyTc]
-- The same caveat applies to IfaceIPTc
\end{code}
Note [The Name of an IfaceAnyTc]
......@@ -204,7 +183,8 @@ pprIfaceIdBndr :: (IfLclName, IfaceType) -> SDoc
pprIfaceIdBndr (name, ty) = hsep [ppr name, dcolon, ppr ty]
pprIfaceTvBndr :: IfaceTvBndr -> SDoc
pprIfaceTvBndr (tv, IfaceTyConApp IfaceLiftedTypeKindTc [])
pprIfaceTvBndr (tv, IfaceTyConApp (IfaceTc n) [])
| n == liftedTypeKindTyConName
= ppr tv
pprIfaceTvBndr (tv, kind) = parens (ppr tv <> dcolon <> ppr kind)
pprIfaceTvBndrs :: [IfaceTvBndr] -> SDoc
......@@ -269,15 +249,20 @@ pprIfaceForAllPart tvs ctxt doc
-------------------
ppr_tc_app :: Int -> IfaceTyCon -> [IfaceType] -> SDoc
ppr_tc_app _ tc [] = ppr_tc tc
ppr_tc_app _ IfaceListTc [ty] = brackets (pprIfaceType ty)
ppr_tc_app _ IfacePArrTc [ty] = pabrackets (pprIfaceType ty)
ppr_tc_app _ (IfaceTupTc bx arity) tys
| arity == length tys
= tupleParens bx (sep (punctuate comma (map pprIfaceType tys)))
ppr_tc_app _ (IfaceIPTc n) [ty] = parens (ppr (IPName n) <> dcolon <> pprIfaceType ty)