summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/basicTypes/Name.lhs8
-rw-r--r--compiler/basicTypes/Unique.lhs3
-rw-r--r--compiler/coreSyn/CoreLint.lhs2
-rw-r--r--compiler/iface/BinIface.hs291
-rw-r--r--compiler/iface/IfaceEnv.lhs35
-rw-r--r--compiler/iface/IfaceSyn.lhs9
-rw-r--r--compiler/iface/IfaceType.lhs86
-rw-r--r--compiler/iface/MkIface.lhs28
-rw-r--r--compiler/iface/TcIface.lhs23
-rw-r--r--compiler/main/GhcMonad.hs3
-rw-r--r--compiler/parser/ParserCore.y21
-rw-r--r--compiler/prelude/PrelInfo.lhs2
-rw-r--r--compiler/prelude/PrelNames.lhs68
-rw-r--r--compiler/prelude/TysPrim.lhs7
-rw-r--r--compiler/prelude/TysWiredIn.lhs5
-rw-r--r--compiler/types/TyCon.lhs6
-rw-r--r--compiler/utils/Binary.hs46
17 files changed, 323 insertions, 320 deletions
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index 754f6292b2..1933740ed7 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -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}
%************************************************************************
diff --git a/compiler/basicTypes/Unique.lhs b/compiler/basicTypes/Unique.lhs
index 39e61027f1..e7411e7883 100644
--- a/compiler/basicTypes/Unique.lhs
+++ b/compiler/basicTypes/Unique.lhs
@@ -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
diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 34e294f389..6f2fd61f8e 100644
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -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
diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 083e85c27b..668c472b79 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -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)
diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs
index 98c21fd286..eb34402594 100644
--- a/compiler/iface/IfaceEnv.lhs
+++ b/compiler/iface/IfaceEnv.lhs
@@ -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}
diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs
index 6374ac1cd9..9a2e89db70 100644
--- a/compiler/iface/IfaceSyn.lhs
+++ b/compiler/iface/IfaceSyn.lhs
@@ -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
diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs
index b9fcb8f27d..f2bf13d42a 100644
--- a/compiler/iface/IfaceType.lhs
+++ b/compiler/iface/IfaceType.lhs
@@ -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)
-ppr_tc_app ctxt_prec tc tys
+ppr_tc_app _ (IfaceTc n) [ty] | n == listTyConName = brackets (pprIfaceType ty)
+ppr_tc_app _ (IfaceTc n) [ty] | n == parrTyConName = pabrackets (pprIfaceType ty)
+ppr_tc_app _ (IfaceTc n) tys
+ | Just (ATyCon tc) <- wiredInNameTyThing_maybe n
+ , Just sort <- tyConTuple_maybe tc
+ , tyConArity tc == length tys
+ = tupleParens sort (sep (punctuate comma (map pprIfaceType tys)))
+ | Just (ATyCon tc) <- wiredInNameTyThing_maybe n
+ , Just ip <- tyConIP_maybe tc
+ , [ty] <- tys
+ = parens (ppr ip <> dcolon <> pprIfaceType ty)
+ppr_tc_app ctxt_prec tc tys
= maybeParen ctxt_prec tYCON_PREC
- (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
+ (sep [ppr_tc tc, nest 4 (sep (map pprParendIfaceType tys))])
ppr_tc :: IfaceTyCon -> SDoc
-- Wrap infix type constructors in parens
@@ -286,12 +271,11 @@ ppr_tc tc = ppr tc
-------------------
instance Outputable IfaceTyCon where
- ppr (IfaceIPTc n) = ppr (IPName n)
ppr (IfaceAnyTc k) = ptext (sLit "Any") <> pprParendIfaceType k
- -- We can't easily get the Name of an IfaceAnyTc/IfaceIPTc
+ -- We can't easily get the Name of an IfaceAnyTc
-- (see Note [The Name of an IfaceAnyTc])
-- so we fake it. It's only for debug printing!
- ppr other_tc = ppr (ifaceTyConName other_tc)
+ ppr (IfaceTc ext) = ppr ext
instance Outputable IfaceCoCon where
ppr (IfaceCoAx n) = ppr n
@@ -357,19 +341,10 @@ toIfaceCoVar :: CoVar -> FastString
toIfaceCoVar = occNameFS . getOccName
----------------
--- A little bit of (perhaps optional) trickiness here. When
--- compiling Data.Tuple, the tycons are not TupleTyCons, although
--- they have a wired-in name. But we'd like to dump them into the Iface
--- as a tuple tycon, to save lookups when reading the interface
--- Hence a tuple tycon may 'miss' in toIfaceTyCon, but then
--- toIfaceTyCon_name will still catch it.
-
toIfaceTyCon :: TyCon -> IfaceTyCon
toIfaceTyCon tc
- | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc)
| isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc))
- | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n)
- | otherwise = toIfaceTyCon_name (tyConName tc)
+ | otherwise = IfaceTc (tyConName tc)
toIfaceTyCon_name :: Name -> IfaceTyCon
toIfaceTyCon_name nm
@@ -380,20 +355,7 @@ toIfaceTyCon_name nm
toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon
toIfaceWiredInTyCon tc nm
- | isTupleTyCon tc = IfaceTupTc (tupleTyConSort tc) (tyConArity tc)
| isAnyTyCon tc = IfaceAnyTc (toIfaceKind (tyConKind tc))
- | Just n <- tyConIP_maybe tc = IfaceIPTc (ipFastString n)
- | nm == intTyConName = IfaceIntTc
- | nm == boolTyConName = IfaceBoolTc
- | nm == charTyConName = IfaceCharTc
- | nm == listTyConName = IfaceListTc
- | nm == parrTyConName = IfacePArrTc
- | nm == liftedTypeKindTyConName = IfaceLiftedTypeKindTc
- | nm == unliftedTypeKindTyConName = IfaceUnliftedTypeKindTc
- | nm == openTypeKindTyConName = IfaceOpenTypeKindTc
- | nm == argTypeKindTyConName = IfaceArgTypeKindTc
- | nm == constraintKindTyConName = IfaceConstraintKindTc
- | nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc
| otherwise = IfaceTc nm
----------------
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 1688d2314d..992b8c7cb0 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -1648,15 +1648,9 @@ toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r)
---------------------
toIfaceCon :: AltCon -> IfaceConAlt
-toIfaceCon (DataAlt dc) | isTupleTyCon tc
- = IfaceTupleAlt (tupleTyConSort tc)
- | otherwise
- = IfaceDataAlt (getName dc)
- where
- tc = dataConTyCon dc
-
-toIfaceCon (LitAlt l) = IfaceLitAlt l
-toIfaceCon DEFAULT = IfaceDefault
+toIfaceCon (DataAlt dc) = IfaceDataAlt (getName dc)
+toIfaceCon (LitAlt l) = IfaceLitAlt l
+toIfaceCon DEFAULT = IfaceDefault
---------------------
toIfaceApp :: Expr CoreBndr -> [Arg CoreBndr] -> IfaceExpr
@@ -1681,15 +1675,11 @@ mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as
---------------------
toIfaceVar :: Id -> IfaceExpr
-toIfaceVar v = case isDataConWorkId_maybe v of
- Just dc | isTupleTyCon tc -> IfaceTupId (tupleTyConSort tc) (tupleTyConArity tc)
- where tc = dataConTyCon dc
- -- Tuple workers also have special syntax, so we get their
- -- Uniques right (they are wired-in but infinite)
- _ | Just fcall <- isFCallId_maybe v -> IfaceFCall fcall (toIfaceType (idType v))
- -- Foreign calls have special syntax
- | isExternalName name -> IfaceExt name
- | Just (TickBox m ix) <- isTickBoxOp_maybe v -> IfaceTick m ix
- | otherwise -> IfaceLcl (getFS name)
+toIfaceVar v
+ | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v))
+ -- Foreign calls have special syntax
+ | isExternalName name = IfaceExt name
+ | Just (TickBox m ix) <- isTickBoxOp_maybe v = IfaceTick m ix
+ | otherwise = IfaceLcl (getFS name)
where name = idName v
\end{code}
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 328770b5f8..2115034b38 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -894,9 +894,6 @@ tcIfaceExpr (IfaceTick modName tickNo)
tcIfaceExpr (IfaceExt gbl)
= Var <$> tcIfaceExtId gbl
-tcIfaceExpr (IfaceTupId boxity arity)
- = return $ Var (dataConWorkId (tupleCon boxity arity))
-
tcIfaceExpr (IfaceLit lit)
= do lit' <- tcIfaceLit lit
return (Lit lit')
@@ -1007,11 +1004,6 @@ tcIfaceAlt scrut (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs)
(failIfM (ppr scrut $$ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon)))
; tcIfaceDataAlt con inst_tys arg_strs rhs }
-tcIfaceAlt _ (tycon, inst_tys) (IfaceTupleAlt _boxity, arg_occs, rhs)
- = ASSERT2( isTupleTyCon tycon && tupleTyConSort tycon == _boxity, ppr tycon )
- do { let [data_con] = tyConDataCons tycon
- ; tcIfaceDataAlt data_con inst_tys arg_occs rhs }
-
tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
-> IfL (AltCon, [TyVar], CoreExpr)
tcIfaceDataAlt con inst_tys arg_strs rhs
@@ -1254,14 +1246,6 @@ tcIfaceGlobal name
-- emasculated form (e.g. lacking data constructors).
tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
-tcIfaceTyCon IfaceIntTc = tcWiredInTyCon intTyCon
-tcIfaceTyCon IfaceBoolTc = tcWiredInTyCon boolTyCon
-tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon
-tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon
-tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon
-tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar)
-tcIfaceTyCon (IfaceIPTc n) = do { n' <- newIPName n
- ; tcWiredInTyCon (ipTyCon n') }
tcIfaceTyCon (IfaceAnyTc kind) = do { tc_kind <- tcIfaceType kind
; tcWiredInTyCon (anyTyConOfKind tc_kind) }
tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
@@ -1272,13 +1256,6 @@ tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name
IfaceTc _ -> tc
_ -> pprTrace "check_tc" (ppr tc) tc
| otherwise = tc
--- we should be okay just returning Kind constructors without extra loading
-tcIfaceTyCon IfaceLiftedTypeKindTc = return liftedTypeKindTyCon
-tcIfaceTyCon IfaceOpenTypeKindTc = return openTypeKindTyCon
-tcIfaceTyCon IfaceUnliftedTypeKindTc = return unliftedTypeKindTyCon
-tcIfaceTyCon IfaceArgTypeKindTc = return argTypeKindTyCon
-tcIfaceTyCon IfaceUbxTupleKindTc = return ubxTupleKindTyCon
-tcIfaceTyCon IfaceConstraintKindTc = return constraintKindTyCon
-- Even though we are in an interface file, we want to make
-- sure the instances and RULES of this tycon are loaded
diff --git a/compiler/main/GhcMonad.hs b/compiler/main/GhcMonad.hs
index 4c72f144c2..816cc4b922 100644
--- a/compiler/main/GhcMonad.hs
+++ b/compiler/main/GhcMonad.hs
@@ -105,6 +105,9 @@ instance Monad Ghc where
instance MonadIO Ghc where
liftIO ioA = Ghc $ \_ -> ioA
+instance MonadFix Ghc where
+ mfix f = Ghc $ \s -> mfix (\x -> unGhc (f x) s)
+
instance ExceptionMonad Ghc where
gcatch act handle =
Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y
index cd76284df8..99efa7a4ae 100644
--- a/compiler/parser/ParserCore.y
+++ b/compiler/parser/ParserCore.y
@@ -15,19 +15,20 @@ import RdrHsSyn
import HsSyn
import RdrName
import OccName
+import TypeRep ( TyThing(..) )
import Type ( Kind,
liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
argTypeKindTyCon, ubxTupleKindTyCon, mkTyConApp
)
import Coercion( mkArrowKind )
-import Name( Name, nameOccName, nameModule, mkExternalName )
+import Name( Name, nameOccName, nameModule, mkExternalName, wiredInNameTyThing_maybe )
import Module
import ParserCoreUtils
import LexCore
import Literal
import SrcLoc
-import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon,
- floatPrimTyCon, doublePrimTyCon, addrPrimTyCon )
+import PrelNames
+import TysPrim
import TyCon ( TyCon, tyConName )
import FastString
import Outputable
@@ -362,18 +363,14 @@ toKind (IfaceTyConApp ifKc []) = mkTyConApp (toKindTc ifKc) []
toKind other = pprPanic "toKind" (ppr other)
toKindTc :: IfaceTyCon -> TyCon
-toKindTc IfaceLiftedTypeKindTc = liftedTypeKindTyCon
-toKindTc IfaceOpenTypeKindTc = openTypeKindTyCon
-toKindTc IfaceUnliftedTypeKindTc = unliftedTypeKindTyCon
-toKindTc IfaceUbxTupleKindTc = ubxTupleKindTyCon
-toKindTc IfaceArgTypeKindTc = argTypeKindTyCon
-toKindTc other = pprPanic "toKindTc" (ppr other)
+toKindTc (IfaceTc n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n = tc
+toKindTc other = pprPanic "toKindTc" (ppr other)
ifaceTcType ifTc = IfaceTyConApp ifTc []
-ifaceLiftedTypeKind = ifaceTcType IfaceLiftedTypeKindTc
-ifaceOpenTypeKind = ifaceTcType IfaceOpenTypeKindTc
-ifaceUnliftedTypeKind = ifaceTcType IfaceUnliftedTypeKindTc
+ifaceLiftedTypeKind = ifaceTcType (IfaceTc liftedTypeKindTyConName)
+ifaceOpenTypeKind = ifaceTcType (IfaceTc openTypeKindTyConName)
+ifaceUnliftedTypeKind = ifaceTcType (IfaceTc unliftedTypeKindTyConName)
ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2
diff --git a/compiler/prelude/PrelInfo.lhs b/compiler/prelude/PrelInfo.lhs
index c4a47f44a7..98531e28af 100644
--- a/compiler/prelude/PrelInfo.lhs
+++ b/compiler/prelude/PrelInfo.lhs
@@ -68,7 +68,7 @@ Notes about wired in things
wiredInThings :: [TyThing]
-- This list is used only to initialise HscMain.knownKeyNames
-- to ensure that when you say "Prelude.map" in your source code, you
--- get a Name with the correct known key
+-- get a Name with the correct known key (See Note [Known-key names])
wiredInThings
= concat
[ -- Wired in TyCons and their implicit Ids
diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs
index e7eca77def..1f3eb98aae 100644
--- a/compiler/prelude/PrelNames.lhs
+++ b/compiler/prelude/PrelNames.lhs
@@ -35,6 +35,57 @@ Nota Bene: all Names defined in here should come from the base package
the uniques for these guys, only their names
+Note [Known-key names]
+~~~~~~~~~~~~~~~~~~~~~~
+
+It is *very* important that the compiler gives wired-in things and things with "known-key" names
+the correct Uniques wherever they occur. We have to be careful about this in exactly two places:
+
+ 1. When we parse some source code, renaming the AST better yield an AST whose Names have the
+ correct uniques
+
+ 2. When we read an interface file, the read-in gubbins better have the right uniques
+
+This is accomplished through a combination of mechanisms:
+
+ 1. When parsing source code, the RdrName-decorated AST has some RdrNames which are Exact. These are
+ wired-in RdrNames where the we could directly tell from the parsed syntax what Name to use. For
+ example, when we parse a [] in a type we can just insert an Exact RdrName Name with the listTyConKey.
+
+ Currently, I believe this is just an optimisation: it would be equally valid to just output Orig
+ RdrNames that correctly record the module etc we expect the final Name to come from. However,
+ were we to eliminate isTupleOcc_maybe it would become essential (see point 3).
+
+ 2. The knownKeyNames (which consist of the basicKnownKeyNames from the module, and those names reachable
+ via the wired-in stuff from TysWiredIn) are used to initialise the "original name cache" in IfaceEnv.
+ This initialization ensures that when the type checker or renamer (both of which use IfaceEnv) look up
+ an original name (i.e. a pair of a Module and an OccName) for a known-key name they get the correct Unique.
+
+ This is the most important mechanism for ensuring that known-key stuff gets the right Unique, and is why
+ it is so important to place your known-key names in the appropriate lists.
+
+ 3. For "infinite families" of known-key names (i.e. tuples, Any tycons and implicit parameter TyCons), we
+ have to be extra careful. Because there are an infinite number of these things, we cannot add them to
+ the list of known-key names used to initialise the original name cache. Instead, we have to rely on
+ never having to look them up in that cache.
+
+ This is accomplished through a variety of mechanisms:
+
+ a) The known infinite families of names are specially serialised by BinIface.putName, with that special treatment
+ detected when we read back to ensure that we get back to the correct uniques.
+
+ b) Most of the infinite families cannot occur in source code, so mechanism a) sufficies to ensure that they
+ always have the right Unique. In particular, implicit param TyCon names, constraint tuples and Any TyCons
+ cannot be mentioned by the user.
+
+ c) Tuple TyCon/DataCon names have a special hack (isTupleOcc_maybe) that is used by the original name cache
+ lookup routine to detect tuple names and give them the right Unique. You might think that this is unnecessary
+ because tuple TyCon/DataCons are parsed as Exact RdrNames and *don't* appear as original names in interface files
+ (because serialization gives them special treatment), so we will never look them up in the original name cache.
+
+ However, there is a subtle reason why this is not the case: if you use setRdrNameSpace on an Exact RdrName
+ it may be turned into an Orig RdrName. So if the original name was an Exact tuple Name we might end up with
+ an Orig instead, which *will* lead to an original name cache query.
\begin{code}
module PrelNames (
Unique, Uniquable(..), hasKey, -- Re-exported for convenience
@@ -1593,23 +1644,6 @@ mzipIdKey = mkPreludeMiscIdUnique 197
%************************************************************************
%* *
-\subsection{Standard groups of types}
-%* *
-%************************************************************************
-
-\begin{code}
-kindKeys :: [Unique]
-kindKeys = [ liftedTypeKindTyConKey
- , openTypeKindTyConKey
- , unliftedTypeKindTyConKey
- , ubxTupleKindTyConKey
- , argTypeKindTyConKey
- , constraintKindTyConKey ]
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[Class-std-groups]{Standard groups of Prelude classes}
%* *
%************************************************************************
diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs
index 43fd143e55..7ac491755a 100644
--- a/compiler/prelude/TysPrim.lhs
+++ b/compiler/prelude/TysPrim.lhs
@@ -121,6 +121,13 @@ primTyCons
, word64PrimTyCon
, anyTyCon
, eqPrimTyCon
+
+ , liftedTypeKindTyCon
+ , unliftedTypeKindTyCon
+ , openTypeKindTyCon
+ , argTypeKindTyCon
+ , ubxTupleKindTyCon
+ , constraintKindTyCon
]
mkPrimTc :: FastString -> Unique -> TyCon -> Name
diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs
index 6b64ae7f7d..e31261afac 100644
--- a/compiler/prelude/TysWiredIn.lhs
+++ b/compiler/prelude/TysWiredIn.lhs
@@ -120,10 +120,9 @@ names in PrelNames, so they use wTcQual, wDataQual, etc
-- Because of their infinite nature, this list excludes tuples, Any and implicit
-- parameter TyCons. Instead, we have a hack in lookupOrigNameCache to deal with
-- these names.
+--
+-- See also Note [Known-key names]
wiredInTyCons :: [TyCon]
--- It does not need to include kind constructors, because
--- all that wiredInThings does is to initialise the Name table,
--- and kind constructors don't appear in source code.
wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because
-- it's defined in GHC.Base, and there's only
diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs
index ae6c248f18..c8766d9c6f 100644
--- a/compiler/types/TyCon.lhs
+++ b/compiler/types/TyCon.lhs
@@ -61,7 +61,7 @@ module TyCon(
tyConStupidTheta,
tyConArity,
tyConParent,
- tyConClass_maybe, tyConIP_maybe,
+ tyConTuple_maybe, tyConClass_maybe, tyConIP_maybe,
tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe,
synTyConDefn, synTyConRhs, synTyConType,
tyConExtName, -- External name for foreign types
@@ -1375,6 +1375,10 @@ tyConClass_maybe :: TyCon -> Maybe Class
tyConClass_maybe (AlgTyCon {algTcParent = ClassTyCon clas}) = Just clas
tyConClass_maybe _ = Nothing
+tyConTuple_maybe :: TyCon -> Maybe TupleSort
+tyConTuple_maybe (TupleTyCon {tyConTupleSort = sort}) = Just sort
+tyConTuple_maybe _ = Nothing
+
-- | If this 'TyCon' is that for implicit parameter, return the IP it is for.
-- Otherwise returns @Nothing@
tyConIP_maybe :: TyCon -> Maybe (IPName Name)
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index b61b2838ee..afbb665b46 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -18,6 +18,7 @@ module Binary
( {-type-} Bin,
{-class-} Binary(..),
{-type-} BinHandle,
+ SymbolTable, Dictionary,
openBinIO, openBinIO_,
openBinMem,
@@ -249,8 +250,7 @@ computeFingerprint :: Binary a
computeFingerprint put_name a = do
bh <- openBinMem (3*1024) -- just less than a block
- ud <- newWriteState put_name putFS
- bh <- return $ setUserData bh ud
+ bh <- return $ setUserData bh $ newWriteState put_name putFS
put_ bh a
fingerprintBinMem bh
@@ -634,31 +634,33 @@ lazyGet bh = do
data UserData =
UserData {
-- for *deserialising* only:
- ud_dict :: Dictionary,
- ud_symtab :: SymbolTable,
+ ud_get_name :: BinHandle -> IO Name,
+ ud_get_fs :: BinHandle -> IO FastString,
-- for *serialising* only:
ud_put_name :: BinHandle -> Name -> IO (),
ud_put_fs :: BinHandle -> FastString -> IO ()
}
-newReadState :: Dictionary -> IO UserData
-newReadState dict = do
- return UserData { ud_dict = dict,
- ud_symtab = undef "symtab",
- ud_put_name = undef "put_name",
- ud_put_fs = undef "put_fs"
- }
-
+newReadState :: (BinHandle -> IO Name)
+ -> (BinHandle -> IO FastString)
+ -> UserData
+newReadState get_name get_fs
+ = UserData { ud_get_name = get_name,
+ ud_get_fs = get_fs,
+ ud_put_name = undef "put_name",
+ ud_put_fs = undef "put_fs"
+ }
+
newWriteState :: (BinHandle -> Name -> IO ())
-> (BinHandle -> FastString -> IO ())
- -> IO UserData
-newWriteState put_name put_fs = do
- return UserData { ud_dict = undef "dict",
- ud_symtab = undef "symtab",
- ud_put_name = put_name,
- ud_put_fs = put_fs
- }
+ -> UserData
+newWriteState put_name put_fs
+ = UserData { ud_get_name = undef "get_name",
+ ud_get_fs = undef "get_fs",
+ ud_put_name = put_name,
+ ud_put_fs = put_fs
+ }
noUserData :: a
noUserData = undef "UserData"
@@ -736,9 +738,9 @@ instance Binary FastString where
case getUserData bh of
UserData { ud_put_fs = put_fs } -> put_fs bh f
- get bh = do
- j <- get bh
- return $! (ud_dict (getUserData bh) ! (fromIntegral (j :: Word32)))
+ get bh =
+ case getUserData bh of
+ UserData { ud_get_fs = get_fs } -> get_fs bh
-- Here to avoid loop
View Lorry Controller Status