diff options
Diffstat (limited to 'compiler/iface')
| -rw-r--r-- | compiler/iface/BinIface.hs | 291 | ||||
| -rw-r--r-- | compiler/iface/IfaceEnv.lhs | 35 | ||||
| -rw-r--r-- | compiler/iface/IfaceSyn.lhs | 9 | ||||
| -rw-r--r-- | compiler/iface/IfaceType.lhs | 86 | ||||
| -rw-r--r-- | compiler/iface/MkIface.lhs | 28 | ||||
| -rw-r--r-- | compiler/iface/TcIface.lhs | 23 |
6 files changed, 215 insertions, 257 deletions
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 |