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.

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}
 
 %************************************************************************

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

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

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)
 

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}
 
 

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

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