Change the way IfExtName is serialized so (most) wired-in names get special represent...
authorMax Bolingbroke <batterseapower@hotmail.com>
Sat, 10 Sep 2011 09:16:38 +0000 (10:16 +0100)
committerMax Bolingbroke <batterseapower@hotmail.com>
Tue, 27 Sep 2011 05:40:58 +0000 (06:40 +0100)
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.

17 files changed:
compiler/basicTypes/Name.lhs
compiler/basicTypes/Unique.lhs
compiler/coreSyn/CoreLint.lhs
compiler/iface/BinIface.hs
compiler/iface/IfaceEnv.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/GhcMonad.hs
compiler/parser/ParserCore.y
compiler/prelude/PrelInfo.lhs
compiler/prelude/PrelNames.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/TysWiredIn.lhs
compiler/types/TyCon.lhs
compiler/utils/Binary.hs

index 754f629..1933740 100644 (file)
@@ -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}
 
 %************************************************************************
index 39e6102..e7411e7 100644 (file)
@@ -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
index 34e294f..6f2fd61 100644 (file)
@@ -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
index 083e85c..668c472 100644 (file)
@@ -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)
 
index 98c21fd..eb34402 100644 (file)
@@ -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}
 
 
index 6374ac1..9a2e89d 100644 (file)
@@ -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
index b9fcb8f..f2bf13d 100644 (file)
@@ -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
 
 ----------------
index 1688d23..992b8c7 100644 (file)
@@ -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}
index 328770b..2115034 100644 (file)
@@ -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 
index 4c72f14..816cc4b 100644 (file)
@@ -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
index cd76284..99efa7a 100644 (file)
@@ -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
 
index c4a47f4..98531e2 100644 (file)
@@ -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
index e7eca77..1f3eb98 100644 (file)
@@ -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}
 %*                                                                      *
 %************************************************************************
index 43fd143..7ac4917 100644 (file)
@@ -121,6 +121,13 @@ primTyCons
     , word64PrimTyCon
     , anyTyCon
     , eqPrimTyCon
+
+    , liftedTypeKindTyCon
+    , unliftedTypeKindTyCon
+    , openTypeKindTyCon
+    , argTypeKindTyCon
+    , ubxTupleKindTyCon
+    , constraintKindTyCon
     ]
 
 mkPrimTc :: FastString -> Unique -> TyCon -> Name
index 6b64ae7..e31261a 100644 (file)
@@ -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
index ae6c248..c8766d9 100644 (file)
@@ -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)
index b61b283..afbb665 100644 (file)
@@ -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