diff options
36 files changed, 1618 insertions, 1399 deletions
diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index d927e16a71..9818eba2f9 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -895,7 +895,7 @@ mkPrimOpId prim_op ty = mkForAllTys tyvars (mkFunTys arg_tys res_ty) name = mkWiredInName gHC_PRIM (primOpOcc prim_op) (mkPrimOpIdUnique (primOpTag prim_op)) - Nothing (AnId id) UserSyntax + (AnId id) UserSyntax id = mkGlobalId (PrimOpId prim_op) name ty info info = noCafIdInfo @@ -1034,7 +1034,7 @@ another gun with which to shoot yourself in the foot. \begin{code} mkWiredInIdName mod fs uniq id - = mkWiredInName mod (mkOccNameFS varName fs) uniq Nothing (AnId id) UserSyntax + = mkWiredInName mod (mkOccNameFS varName fs) uniq (AnId id) UserSyntax unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 25db76171c..df97181b34 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -21,7 +21,7 @@ module Name ( tidyNameOcc, hashName, localiseName, - nameSrcLoc, nameParent, nameParent_maybe, isImplicitName, + nameSrcLoc, isSystemName, isInternalName, isExternalName, isTyVarName, isTyConName, isWiredInName, isBuiltInSyntax, @@ -40,13 +40,18 @@ import {-# SOURCE #-} TypeRep( TyThing ) import OccName -- All of it import Module ( Module ) import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc ) +import UniqFM ( lookupUFM, addToUFM ) import Unique ( Unique, Uniquable(..), getKey, pprUnique, mkUniqueGrimily, getKey# ) import Maybes ( orElse, isJust ) +import Binary +import FastMutInt import FastString ( FastString, zEncodeFS ) import Outputable +import DATA_IOREF import GLAEXTS ( Int#, Int(..) ) +import Data.Array ( (!) ) \end{code} %************************************************************************ @@ -68,12 +73,9 @@ data Name = Name { -- the SrcLoc in a Name all that often. data NameSort - = External Module (Maybe Name) - -- (Just parent) => this Name is a subordinate name of 'parent' - -- e.g. data constructor of a data type, method of a class - -- Nothing => not a subordinate + = External Module - | WiredIn Module (Maybe Name) TyThing BuiltInSyntax + | WiredIn Module TyThing BuiltInSyntax -- A variant of External, for wired-in things | Internal -- A user-defined Id or TyVar @@ -137,41 +139,26 @@ isExternalName :: Name -> Bool isSystemName :: Name -> Bool isWiredInName :: Name -> Bool -isWiredInName (Name {n_sort = WiredIn _ _ _ _}) = True -isWiredInName other = False +isWiredInName (Name {n_sort = WiredIn _ _ _}) = True +isWiredInName other = False wiredInNameTyThing_maybe :: Name -> Maybe TyThing -wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ _ thing _}) = Just thing -wiredInNameTyThing_maybe other = Nothing +wiredInNameTyThing_maybe (Name {n_sort = WiredIn _ thing _}) = Just thing +wiredInNameTyThing_maybe other = Nothing -isBuiltInSyntax (Name {n_sort = WiredIn _ _ _ BuiltInSyntax}) = True -isBuiltInSyntax other = False +isBuiltInSyntax (Name {n_sort = WiredIn _ _ BuiltInSyntax}) = True +isBuiltInSyntax other = False -isExternalName (Name {n_sort = External _ _}) = True -isExternalName (Name {n_sort = WiredIn _ _ _ _}) = True -isExternalName other = False +isExternalName (Name {n_sort = External _}) = True +isExternalName (Name {n_sort = WiredIn _ _ _}) = True +isExternalName other = False isInternalName name = not (isExternalName name) -nameParent_maybe :: Name -> Maybe Name -nameParent_maybe (Name {n_sort = External _ p}) = p -nameParent_maybe (Name {n_sort = WiredIn _ p _ _}) = p -nameParent_maybe other = Nothing - -nameParent :: Name -> Name -nameParent name = case nameParent_maybe name of - Just parent -> parent - Nothing -> name - -isImplicitName :: Name -> Bool --- An Implicit Name is one has a parent; that is, one whose definition --- derives from the parent thing -isImplicitName name = isJust (nameParent_maybe name) - nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) -nameModule_maybe (Name { n_sort = External mod _}) = Just mod -nameModule_maybe (Name { n_sort = WiredIn mod _ _ _}) = Just mod -nameModule_maybe name = Nothing +nameModule_maybe (Name { n_sort = External mod}) = Just mod +nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod +nameModule_maybe name = Nothing nameIsLocalOrFrom from name | isExternalName name = from == nameModule name @@ -206,16 +193,16 @@ mkInternalName uniq occ loc = Name { n_uniq = getKey# uniq, n_sort = Internal, n -- * for interface files we tidyCore first, which puts the uniques -- into the print name (see setNameVisibility below) -mkExternalName :: Unique -> Module -> OccName -> Maybe Name -> SrcLoc -> Name -mkExternalName uniq mod occ mb_parent loc - = Name { n_uniq = getKey# uniq, n_sort = External mod mb_parent, +mkExternalName :: Unique -> Module -> OccName -> SrcLoc -> Name +mkExternalName uniq mod occ loc + = Name { n_uniq = getKey# uniq, n_sort = External mod, n_occ = occ, n_loc = loc } -mkWiredInName :: Module -> OccName -> Unique - -> Maybe Name -> TyThing -> BuiltInSyntax -> Name -mkWiredInName mod occ uniq mb_parent thing built_in +mkWiredInName :: Module -> OccName -> Unique -> TyThing -> BuiltInSyntax + -> Name +mkWiredInName mod occ uniq thing built_in = Name { n_uniq = getKey# uniq, - n_sort = WiredIn mod mb_parent thing built_in, + n_sort = WiredIn mod thing built_in, n_occ = occ, n_loc = wiredInSrcLoc } mkSystemName :: Unique -> OccName -> Name @@ -301,6 +288,33 @@ instance NamedThing Name where getName n = n \end{code} +%************************************************************************ +%* * +\subsection{Binary} +%* * +%************************************************************************ + +\begin{code} +instance Binary Name where + put_ bh name = do + case getUserData bh of { + UserData { ud_symtab_map = symtab_map_ref, + ud_symtab_next = symtab_next } -> do + symtab_map <- readIORef symtab_map_ref + case lookupUFM symtab_map name of + Just (off,_) -> put_ bh off + Nothing -> do + off <- readFastMutInt symtab_next + writeFastMutInt symtab_next (off+1) + writeIORef symtab_map_ref + $! addToUFM symtab_map name (off,name) + put_ bh off + } + + get bh = do + i <- get bh + return $! (ud_symtab (getUserData bh) ! i) +\end{code} %************************************************************************ %* * @@ -318,8 +332,8 @@ instance OutputableBndr Name where pprName name@(Name {n_sort = sort, n_uniq = u#, n_occ = occ}) = getPprStyle $ \ sty -> case sort of - WiredIn mod _ _ builtin -> pprExternal sty uniq mod occ True builtin - External mod _ -> pprExternal sty uniq mod occ False UserSyntax + WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin + External mod -> pprExternal sty uniq mod occ False UserSyntax System -> pprSystem sty uniq occ Internal -> pprInternal sty uniq occ where uniq = mkUniqueGrimily (I# u#) diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index d487b46915..2f7f7a8b50 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -42,7 +42,7 @@ module RdrName ( import OccName import Module ( ModuleName, mkModuleNameFS, Module, moduleName ) -import Name ( Name, NamedThing(getName), nameModule, nameParent_maybe, +import Name ( Name, NamedThing(getName), nameModule, nameOccName, isExternalName, nameSrcLoc ) import Maybes ( mapCatMaybes ) import SrcLoc ( isGoodSrcLoc, isGoodSrcSpan, srcLocSpan, SrcSpan ) @@ -308,8 +308,7 @@ data GlobalRdrElt } instance Outputable GlobalRdrElt where - ppr gre = ppr name <+> pp_parent (nameParent_maybe name) - <+> parens (pprNameProvenance gre) + ppr gre = ppr name <+> parens (pprNameProvenance gre) where name = gre_name gre pp_parent (Just p) = brackets (text "parent:" <+> ppr p) diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 0422a875e1..4c08242612 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -330,7 +330,7 @@ maybeExternaliseId dflags id ; returnFC (setIdName id (externalise mod)) } | otherwise = returnFC id where - externalise mod = mkExternalName uniq mod new_occ Nothing loc + externalise mod = mkExternalName uniq mod new_occ loc name = idName id uniq = nameUnique name new_occ = mkLocalOcc uniq (nameOccName name) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index f49a84c839..29801f28cd 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -13,7 +13,7 @@ import StaticFlags ( opt_SccProfilingOn, opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) import DriverPhases ( isHsBoot ) -import HscTypes ( ModGuts(..), HscEnv(..), +import HscTypes ( ModGuts(..), HscEnv(..), availsToNameSet, Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface ) import HsSyn ( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl ) import TcRnTypes ( TcGblEnv(..), ImportAvails(..) ) @@ -78,7 +78,8 @@ deSugar hsc_env = do { showPass dflags "Desugar" -- Desugar the program - ; let auto_scc = mkAutoScc mod exports + ; let export_set = availsToNameSet exports + ; let auto_scc = mkAutoScc mod export_set ; mb_res <- case ghcMode dflags of JustTypecheck -> return (Just ([], [], NoStubs)) @@ -96,8 +97,8 @@ deSugar hsc_env { -- Add export flags to bindings keep_alive <- readIORef keep_var - ; let final_prs = addExportFlags ghci_mode exports keep_alive - all_prs ds_rules + ; let final_prs = addExportFlags ghci_mode export_set + keep_alive all_prs ds_rules ds_binds = [Rec final_prs] -- Notice that we put the whole lot in a big Rec, even the foreign binds -- When compiling PrelFloat, which defines data Float = F# Float# diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index b4ecf01eb5..6c04002558 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -22,7 +22,7 @@ module DsMeta( dsBracket, import {-# SOURCE #-} DsExpr ( dsExpr ) import MatchLit ( dsLit ) -import DsUtils ( mkListExpr, mkStringExpr, mkIntExpr ) +import DsUtils ( mkListExpr, mkStringExpr, mkCoreTup, mkIntExpr ) import DsMonad import qualified Language.Haskell.TH as TH @@ -1306,6 +1306,9 @@ nonEmptyCoreList :: [Core a] -> Core [a] nonEmptyCoreList [] = panic "coreList: empty argument" nonEmptyCoreList xs@(MkC x:_) = MkC (mkListExpr (exprType x) (map unC xs)) +corePair :: (Core a, Core b) -> Core (a,b) +corePair (MkC x, MkC y) = MkC (mkCoreTup [x,y]) + coreStringLit :: String -> DsM (Core String) coreStringLit s = do { z <- mkStringExpr s; return(MkC z) } diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 3e9895a5bf..3e79a3947c 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -9,20 +9,39 @@ module BinIface ( writeBinIface, readBinIface, v_IgnoreHiWay ) where #include "HsVersions.h" +import TcRnMonad ( TcRnIf, ioToIOEnv ) +import IfaceEnv import HscTypes import BasicTypes import NewDemand import IfaceSyn +import Module ( ModuleName, mkModule, modulePackageId, moduleName ) +import Name +import OccName ( OccName ) import VarEnv import InstEnv ( OverlapFlag(..) ) import Class ( DefMeth(..) ) +import DynFlags ( DynFlags ) +import UniqFM ( UniqFM, eltsUFM ) +import UniqSupply ( uniqFromSupply, splitUniqSupply ) import CostCentre import StaticFlags ( opt_HiVersion, v_Build_tag ) +import Type ( Kind, + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isArgTypeKind, isUbxTupleKind, liftedTypeKind, + unliftedTypeKind, openTypeKind, argTypeKind, + ubxTupleKind, mkArrowKind, splitFunTy_maybe ) +import PackageConfig ( PackageId ) import Panic import Binary +import SrcLoc ( noSrcLoc ) import Util +import ErrUtils ( debugTraceMsg ) import Config ( cGhcUnregisterised ) +import FastMutInt ( readFastMutInt ) +import Data.Word ( Word32 ) +import Data.Array ( Array, array, elems, listArray, (!) ) import DATA_IOREF import EXCEPTION ( throwDyn ) import Monad ( when ) @@ -31,19 +50,164 @@ import Outputable #include "HsVersions.h" -- --------------------------------------------------------------------------- -writeBinIface :: FilePath -> ModIface -> IO () -writeBinIface hi_path mod_iface - = putBinFileWithDict hi_path mod_iface - -readBinIface :: FilePath -> IO ModIface -readBinIface hi_path = getBinFileWithDict hi_path - - --- %********************************************************* --- %* * --- All the Binary instances --- %* * --- %********************************************************* +-- Reading and writing binary interface files + +readBinIface :: FilePath -> TcRnIf a b ModIface +readBinIface hi_path = do + nc <- getNameCache + (new_nc, iface) <- ioToIOEnv $ readBinIface_ hi_path nc + setNameCache new_nc + return iface + +readBinIface_ :: FilePath -> NameCache -> IO (NameCache, ModIface) +readBinIface_ hi_path nc = do + bh <- Binary.readBinMem hi_path + + -- Read the magic number to check that this really is a GHC .hi file + -- (This magic number does not change when we change + -- GHC interface file format) + magic <- get bh + when (magic /= binaryInterfaceMagic) $ + throwDyn (ProgramError ( + "magic number mismatch: old/corrupt interface file?")) + + -- Read the dictionary + -- The next word in the file is a pointer to where the dictionary is + -- (probably at the end of the file) + dict_p <- Binary.get bh -- Get the dictionary ptr + data_p <- tellBin bh -- Remember where we are now + seekBin bh dict_p + dict <- getDictionary bh + 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 + (nc', symtab) <- getSymbolTable bh 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 (nc', iface) + + +writeBinIface :: DynFlags -> FilePath -> ModIface -> IO () +writeBinIface dflags hi_path mod_iface = do + bh <- openBinMem initBinMemSize + put_ bh binaryInterfaceMagic + + -- Remember where the dictionary pointer will go + dict_p_p <- tellBin bh + put_ bh dict_p_p -- Placeholder for ptr to dictionary + + -- Remember where the symbol table pointer will go + symtab_p_p <- tellBin bh + put_ bh symtab_p_p + + -- Make some intial state + ud <- newWriteState + + -- Put the main thing, + bh <- return $ setUserData bh ud + put_ bh mod_iface + + -- Write the symtab pointer at the fornt of the file + symtab_p <- tellBin bh -- This is where the symtab will start + putAt bh symtab_p_p symtab_p -- Fill in the placeholder + seekBin bh symtab_p -- Seek back to the end of the file + + -- Write the symbol table itself + symtab_next <- readFastMutInt (ud_symtab_next ud) + symtab_map <- readIORef (ud_symtab_map ud) + putSymbolTable bh symtab_next symtab_map + debugTraceMsg dflags 3 (text "writeBinIface:" <+> int symtab_next + <+> text "Names") + + -- NB. write the dictionary after the symbol table, because + -- writing the symbol table may create more dictionary entries. + + -- Write the dictionary pointer at the fornt of the file + dict_p <- tellBin bh -- This is where the dictionary will start + putAt bh dict_p_p dict_p -- Fill in the placeholder + seekBin bh dict_p -- Seek back to the end of the file + + -- Write the dictionary itself + dict_next <- readFastMutInt (ud_dict_next ud) + dict_map <- readIORef (ud_dict_map ud) + putDictionary bh dict_next dict_map + debugTraceMsg dflags 3 (text "writeBinIface:" <+> int dict_next + <+> text "dict entries") + + -- And send the result to the file + writeBinMem bh hi_path + +initBinMemSize = (1024*1024) :: Int + +-- The *host* architecture version: +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS == 32 +binaryInterfaceMagic = 0x1face :: Word32 +#elif WORD_SIZE_IN_BITS == 64 +binaryInterfaceMagic = 0x1face64 :: Word32 +#endif + +-- ----------------------------------------------------------------------------- +-- The symbol table + +putSymbolTable :: BinHandle -> Int -> UniqFM (Int,Name) -> IO () +putSymbolTable bh next_off symtab = do + put_ bh next_off + let names = elems (array (0,next_off-1) (eltsUFM symtab)) + mapM_ (\n -> serialiseName bh n symtab) names + +getSymbolTable :: BinHandle -> NameCache -> IO (NameCache, Array Int Name) +getSymbolTable bh namecache = do + sz <- get bh + od_names <- sequence (replicate sz (get bh)) + let + arr = listArray (0,sz-1) names + (namecache', names) = + mapAccumR (fromOnDiskName arr) namecache od_names + -- + return (namecache', arr) + +type OnDiskName = (PackageId, ModuleName, OccName) + +fromOnDiskName + :: Array Int Name + -> NameCache + -> OnDiskName + -> (NameCache, Name) +fromOnDiskName arr nc (pid, mod_name, occ) = + let + mod = mkModule pid mod_name + cache = nsNames nc + in + case lookupOrigNameCache cache mod occ of + Just name -> (nc, name) + Nothing -> + let + us = nsUniqs nc + uniq = uniqFromSupply us + name = mkExternalName uniq mod occ noSrcLoc + new_cache = extendNameCache cache mod occ name + in + case splitUniqSupply us of { (us',_) -> + ( nc{ nsUniqs = us', nsNames = new_cache }, name ) + } + +serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () +serialiseName bh name symtab = do + let mod = nameModule name + put_ bh (modulePackageId mod, moduleName mod, nameOccName name) + +-- ----------------------------------------------------------------------------- +-- All the binary instances -- BasicTypes {-! for IPName derive: Binary !-} @@ -504,36 +668,6 @@ instance Binary CostCentre where -- IfaceTypes and friends ------------------------------------------------------------------------- -instance Binary IfaceExtName where - put_ bh (ExtPkg mod occ) = do - putByte bh 0 - put_ bh mod - put_ bh occ - put_ bh (HomePkg mod occ vers) = do - putByte bh 1 - put_ bh mod - put_ bh occ - put_ bh vers - put_ bh (LocalTop occ) = do - putByte bh 2 - put_ bh occ - put_ bh (LocalTopSub occ _) = do -- Write LocalTopSub just like LocalTop - putByte bh 2 - put_ bh occ - - get bh = do - h <- getByte bh - case h of - 0 -> do mod <- get bh - occ <- get bh - return (ExtPkg mod occ) - 1 -> do mod <- get bh - occ <- get bh - vers <- get bh - return (HomePkg mod occ vers) - _ -> do occ <- get bh - return (LocalTop occ) - instance Binary IfaceBndr where put_ bh (IfaceIdBndr aa) = do putByte bh 0 @@ -884,17 +1018,23 @@ instance Binary IfaceNote where -- IfaceDecl and friends ------------------------------------------------------------------------- +-- A bit of magic going on here: there's no need to store the OccName +-- for a decl on the disk, since we can infer the namespace from the +-- context; however it is useful to have the OccName in the IfaceDecl +-- to avoid re-building it in various places. So we build the OccName +-- when de-serialising. + instance Binary IfaceDecl where put_ bh (IfaceId name ty idinfo) = do putByte bh 0 - put_ bh name + put_ bh (occNameFS name) put_ bh ty put_ bh idinfo put_ bh (IfaceForeign ae af) = error "Binary.put_(IfaceDecl): IfaceForeign" put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do putByte bh 2 - put_ bh a1 + put_ bh (occNameFS a1) put_ bh a2 put_ bh a3 put_ bh a4 @@ -904,14 +1044,14 @@ instance Binary IfaceDecl where put_ bh a8 put_ bh (IfaceSyn aq ar as at) = do putByte bh 3 - put_ bh aq + put_ bh (occNameFS aq) put_ bh ar put_ bh as put_ bh at put_ bh (IfaceClass a1 a2 a3 a4 a5 a6 a7) = do putByte bh 4 put_ bh a1 - put_ bh a2 + put_ bh (occNameFS a2) put_ bh a3 put_ bh a4 put_ bh a5 @@ -923,7 +1063,8 @@ instance Binary IfaceDecl where 0 -> do name <- get bh ty <- get bh idinfo <- get bh - return (IfaceId name ty idinfo) + occ <- return $! mkOccNameFS varName name + return (IfaceId occ ty idinfo) 1 -> error "Binary.get(TyClDecl): ForeignType" 2 -> do a1 <- get bh @@ -934,13 +1075,15 @@ instance Binary IfaceDecl where a6 <- get bh a7 <- get bh a8 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) + occ <- return $! mkOccNameFS tcName a1 + return (IfaceData occ a2 a3 a4 a5 a6 a7 a8) 3 -> do aq <- get bh ar <- get bh as <- get bh at <- get bh - return (IfaceSyn aq ar as at) + occ <- return $! mkOccNameFS tcName aq + return (IfaceSyn occ ar as at) _ -> do a1 <- get bh a2 <- get bh @@ -949,7 +1092,8 @@ instance Binary IfaceDecl where a5 <- get bh a6 <- get bh a7 <- get bh - return (IfaceClass a1 a2 a3 a4 a5 a6 a7) + occ <- return $! mkOccNameFS clsName a2 + return (IfaceClass a1 occ a3 a4 a5 a6 a7) instance Binary IfaceInst where put_ bh (IfaceInst cls tys dfun flag orph) = do @@ -1028,14 +1172,15 @@ instance Binary IfaceConDecl where instance Binary IfaceClassOp where put_ bh (IfaceClassOp n def ty) = do - put_ bh n + put_ bh (occNameFS n) put_ bh def put_ bh ty get bh = do n <- get bh def <- get bh ty <- get bh - return (IfaceClassOp n def ty) + occ <- return $! mkOccNameFS varName n + return (IfaceClassOp occ def ty) instance Binary IfaceRule where put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index 61759658d3..fe0b0cdb22 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -3,31 +3,31 @@ \begin{code} module IfaceEnv ( newGlobalBinder, newIPName, newImplicitBinder, - lookupIfaceTop, lookupIfaceExt, - lookupOrig, lookupIfaceTc, + lookupIfaceTop, + lookupOrig, lookupOrigNameCache, extendNameCache, newIfaceName, newIfaceNames, extendIfaceIdEnv, extendIfaceTyVarEnv, tcIfaceLclId, tcIfaceTyVar, - lookupAvail, ifaceExportNames, + ifaceExportNames, -- Name-cache stuff allocateGlobalBinder, initNameCache, + getNameCache, setNameCache ) where #include "HsVersions.h" import TcRnMonad -import IfaceType ( IfaceExtName(..), IfaceTyCon(..), ifaceTyConName ) import TysWiredIn ( tupleTyCon, tupleCon ) import HscTypes ( NameCache(..), HscEnv(..), GenAvailInfo(..), - IfaceExport, OrigNameCache ) + IfaceExport, OrigNameCache, AvailInfo ) +import Type ( mkOpenTvSubst, substTy ) import TyCon ( TyCon, tyConName ) import DataCon ( dataConWorkId, dataConName ) import Var ( TyVar, Id, varName ) -import Name ( Name, nameUnique, nameModule, - nameOccName, nameSrcLoc, - getOccName, nameParent_maybe, +import Name ( Name, nameUnique, nameModule, + nameOccName, nameSrcLoc, getOccName, isWiredInName, mkIPName, mkExternalName, mkInternalName ) import NameSet ( NameSet, emptyNameSet, addListToNameSet ) @@ -54,7 +54,7 @@ import Outputable %********************************************************* \begin{code} -newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name +newGlobalBinder :: Module -> OccName -> SrcLoc -> TcRnIf a b Name -- Used for source code and interface files, to make the -- Name for a thing, given its Module and OccName -- @@ -62,25 +62,25 @@ newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name -- because we may have seen an occurrence before, but now is the -- moment when we know its Module and SrcLoc in their full glory -newGlobalBinder mod occ mb_parent loc +newGlobalBinder mod occ loc = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help - -- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc) + ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc) ; name_supply <- getNameCache ; let (name_supply', name) = allocateGlobalBinder name_supply mod occ - mb_parent loc + loc ; setNameCache name_supply' ; return name } allocateGlobalBinder :: NameCache - -> Module -> OccName -> Maybe Name -> SrcLoc + -> Module -> OccName -> SrcLoc -> (NameCache, Name) -allocateGlobalBinder name_supply mod occ mb_parent loc +allocateGlobalBinder name_supply mod occ loc = case lookupOrigNameCache (nsNames name_supply) mod occ of -- A hit in the cache! We are at the binding site of the name. - -- This is the moment when we know the defining parent and SrcLoc - -- of the Name, so we set these fields in the Name we return. + -- This is the moment when we know the SrcLoc + -- of the Name, so we set this field in the Name we return. -- -- Then (bogus) multiple bindings of the same Name -- get different SrcLocs can can be reported as such. @@ -98,8 +98,8 @@ allocateGlobalBinder name_supply mod occ mb_parent loc | otherwise -> (new_name_supply, name') where uniq = nameUnique name - name' = mkExternalName uniq mod occ mb_parent loc - new_cache = extend_name_cache (nsNames name_supply) mod occ name' + name' = mkExternalName uniq mod occ loc + new_cache = extendNameCache (nsNames name_supply) mod occ name' new_name_supply = name_supply {nsNames = new_cache} -- Miss in the cache! @@ -108,8 +108,8 @@ allocateGlobalBinder name_supply mod occ mb_parent loc where (us', us1) = splitUniqSupply (nsUniqs name_supply) uniq = uniqFromSupply us1 - name = mkExternalName uniq mod occ mb_parent loc - new_cache = extend_name_cache (nsNames name_supply) mod occ name + name = mkExternalName uniq mod occ loc + new_cache = extendNameCache (nsNames name_supply) mod occ name new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} @@ -119,67 +119,34 @@ newImplicitBinder :: Name -- Base name -- Called in BuildTyCl to allocate the implicit binders of type/class decls -- For source type/class decls, this is the first occurrence -- For iface ones, the LoadIface has alrady allocated a suitable name in the cache --- --- An *implicit* name has the base-name as parent newImplicitBinder base_name mk_sys_occ = newGlobalBinder (nameModule base_name) (mk_sys_occ (nameOccName base_name)) - (Just parent_name) (nameSrcLoc base_name) - where - parent_name = case nameParent_maybe base_name of - Just parent_name -> parent_name - Nothing -> base_name -ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl NameSet -ifaceExportNames exports - = foldlM do_one emptyNameSet exports - where - do_one acc (mod, exports) = foldlM (do_avail mod) acc exports - do_avail mod acc avail = do { ns <- lookupAvail mod avail - ; return (addListToNameSet acc ns) } - -lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b [Name] --- Find all the names arising from an import --- Make sure the parent info is correct, even though we may not --- yet have read the interface for this module -lookupAvail mod (Avail n) = do { n' <- lookupOrig mod n; - ; return [n'] } -lookupAvail mod (AvailTC p_occ occs) - = do { p_name <- lookupOrig mod p_occ - ; let lookup_sub occ | occ == p_occ = return p_name - | otherwise = lookup_orig mod occ (Just p_name) - ; mappM lookup_sub occs } +ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] +ifaceExportNames exports = do + mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports + return (concat mod_avails) + +-- Convert OccNames in GenAvailInfo to Names. +lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo +lookupAvail mod (Avail n) = do + n' <- lookupOrig mod n + return (Avail n') +lookupAvail mod (AvailTC p_occ occs) = do + p_name <- lookupOrig mod p_occ + let lookup_sub occ | occ == p_occ = return p_name + | otherwise = lookupOrig mod occ + subs <- mappM lookup_sub occs + return (AvailTC p_name subs) -- Remember that 'occs' is all the exported things, including -- the parent. It's possible to export just class ops without - -- the class, via C( op ). If the class was exported too we'd - -- have C( C, op ) - - -- The use of lookupOrigSub here (rather than lookupOrig) - -- ensures that the subordinate names record their parent; - -- and that in turn ensures that the GlobalRdrEnv - -- has the correct parent for all the names in its range. - -- For imported things, we may only suck in the interface later, if ever. - -- Reason for all this: - -- Suppose module M exports type A.T, and constructor A.MkT - -- Then, we know that A.MkT is a subordinate name of A.T, - -- even though we aren't at the binding site of A.T - -- And it's important, because we may simply re-export A.T - -- without ever sucking in the declaration itself. - - -lookupOrig :: Module -> OccName -> TcRnIf a b Name --- Even if we get a miss in the original-name cache, we --- make a new External Name. --- We fake up --- SrcLoc to noSrcLoc --- Parent no Nothing --- They'll be overwritten, in due course, by LoadIface.loadDecl. -lookupOrig mod occ = lookup_orig mod occ Nothing - -lookup_orig :: Module -> OccName -> Maybe Name -> TcRnIf a b Name --- Used when we know the parent of the thing we are looking up -lookup_orig mod occ mb_parent + -- the class, which shows up as C( op ) here. If the class was + -- exported too we'd have C( C, op ) + +lookupOrig :: Module -> OccName -> TcRnIf a b Name +lookupOrig mod occ = do { -- First ensure that mod and occ are evaluated -- If not, chaos can ensue: -- we read the name-cache @@ -187,21 +154,22 @@ lookup_orig mod occ mb_parent -- which does some stuff that modifies the name cache -- This did happen, with tycon_mod in TcIface.tcIfaceAlt (DataAlt..) mod `seq` occ `seq` return () + ; traceIf (text "lookup_orig" <+> ppr mod <+> ppr occ) - ; name_supply <- getNameCache - ; case lookupOrigNameCache (nsNames name_supply) mod occ of { - Just name -> returnM name ; - Nothing -> do - - { let { (us', us1) = splitUniqSupply (nsUniqs name_supply) - ; uniq = uniqFromSupply us1 - ; name = mkExternalName uniq mod occ mb_parent noSrcLoc - ; new_cache = extend_name_cache (nsNames name_supply) mod occ name - ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} - } - ; setNameCache new_name_supply - ; return name } - }} + ; name_cache <- getNameCache + ; case lookupOrigNameCache (nsNames name_cache) mod occ of { + Just name -> returnM name; + Nothing -> + let + us = nsUniqs name_cache + uniq = uniqFromSupply us + name = mkExternalName uniq mod occ noSrcLoc + new_cache = extendNameCache (nsNames name_cache) mod occ name + in + case splitUniqSupply us of { (us',_) -> do + setNameCache name_cache{ nsUniqs = us', nsNames = new_cache } + return name + }}} newIPName :: IPName OccName -> TcRnIf m n (IPName Name) newIPName occ_name_ip @@ -246,10 +214,10 @@ lookupOrigNameCache nc mod occ -- The normal case extendOrigNameCache :: OrigNameCache -> Name -> OrigNameCache extendOrigNameCache nc name - = extend_name_cache nc (nameModule name) (nameOccName name) name + = extendNameCache nc (nameModule name) (nameOccName name) name -extend_name_cache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache -extend_name_cache nc mod occ name +extendNameCache :: OrigNameCache -> Module -> OccName -> Name -> OrigNameCache +extendNameCache nc mod occ name = extendModuleEnv_C combine nc mod (unitOccEnv occ name) where combine occ_env _ = extendOccEnv occ_env occ name @@ -324,16 +292,6 @@ extendIfaceTyVarEnv tyvars thing_inside %************************************************************************ \begin{code} -lookupIfaceTc :: IfaceTyCon -> IfL Name -lookupIfaceTc (IfaceTc ext) = lookupIfaceExt ext -lookupIfaceTc other_tc = return (ifaceTyConName other_tc) - -lookupIfaceExt :: IfaceExtName -> IfL Name -lookupIfaceExt (ExtPkg mod occ) = lookupOrig mod occ -lookupIfaceExt (HomePkg mod occ _) = lookupHomePackage mod occ -lookupIfaceExt (LocalTop occ) = lookupIfaceTop occ -lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ - lookupIfaceTop :: OccName -> IfL Name -- Look up a top-level name from the current Iface module lookupIfaceTop occ diff --git a/compiler/iface/IfaceSyn.lhs b/compiler/iface/IfaceSyn.lhs index 8ac4eecc87..a8426081a8 100644 --- a/compiler/iface/IfaceSyn.lhs +++ b/compiler/iface/IfaceSyn.lhs @@ -20,14 +20,14 @@ module IfaceSyn ( IfaceInfoItem(..), IfaceRule(..), IfaceInst(..), IfaceFamInst(..), -- Misc - visibleIfConDecls, + ifaceDeclSubBndrs, visibleIfConDecls, -- Equality - IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, + GenIfaceEq(..), IfaceEq, (&&&), bool, eqListBy, eqMaybeBy, eqIfDecl, eqIfInst, eqIfRule, checkBootDecl, -- Pretty printing - pprIfaceExpr, pprIfaceDecl, pprIfaceDeclHead + pprIfaceExpr, pprIfaceDeclHead ) where #include "HsVersions.h" @@ -37,16 +37,23 @@ import IfaceType import NewDemand ( StrictSig, pprIfaceStrictSig ) import Class ( FunDep, DefMeth, pprFundeps ) -import OccName ( OccName, parenSymOcc, occNameFS, - OccSet, unionOccSets, unitOccSet, occSetElts ) +import OccName import UniqFM ( UniqFM, emptyUFM, addToUFM, lookupUFM ) +import Unique ( mkBuiltinUnique ) +import NameSet +import Name ( Name, NamedThing(..), isExternalName, + mkInternalName ) import CostCentre ( CostCentre, pprCostCentreCore ) import Literal ( Literal ) import ForeignCall ( ForeignCall ) -import BasicTypes ( Arity, Activation(..), StrictnessMark, OverlapFlag, - RecFlag(..), Boxity(..), tupleParens ) +import SrcLoc ( noSrcLoc ) +import BasicTypes import Outputable import FastString +import Maybes ( catMaybes ) + +import Data.List ( nub ) +import Data.Maybe ( isJust ) infixl 3 &&& infix 4 `eqIfExt`, `eqIfIdInfo`, `eqIfType` @@ -101,7 +108,8 @@ data IfaceDecl ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive? } - | IfaceForeign { ifName :: OccName, -- Needs expanding when we move beyond .NET + | IfaceForeign { ifName :: OccName, -- Needs expanding when we move + -- beyond .NET ifExtName :: Maybe FastString } data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType @@ -125,7 +133,7 @@ visibleIfConDecls (IfNewTyCon c) = [c] data IfaceConDecl = IfCon { - ifConOcc :: OccName, -- Constructor name + ifConOcc :: OccName, -- Constructor name ifConInfix :: Bool, -- True <=> declared infix ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars ifConExTvs :: [IfaceTvBndr], -- Existential tyvars @@ -137,9 +145,9 @@ data IfaceConDecl -- or 1-1 corresp with arg tys data IfaceInst - = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with + = IfaceInst { ifInstCls :: Name, -- See comments with ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance - ifDFun :: OccName, -- The dfun + ifDFun :: Name, -- The dfun ifOFlag :: OverlapFlag, -- Overlap flag ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance -- There's always a separate IfaceDecl for the DFun, which gives @@ -150,7 +158,7 @@ data IfaceInst -- and if the head does not change it won't be used if it wasn't before data IfaceFamInst - = IfaceFamInst { ifFamInstFam :: IfaceExtName -- Family tycon + = IfaceFamInst { ifFamInstFam :: Name -- Family tycon , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types , ifFamInstTyCon :: IfaceTyCon -- Instance decl } @@ -160,7 +168,7 @@ data IfaceRule ifRuleName :: RuleName, ifActivation :: Activation, ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars - ifRuleHead :: IfaceExtName, -- Head of lhs + ifRuleHead :: Name, -- Head of lhs ifRuleArgs :: [IfaceExpr], -- Args of LHS ifRuleRhs :: IfaceExpr, ifRuleOrph :: Maybe OccName -- Just like IfaceInst @@ -186,7 +194,7 @@ data IfaceInfoItem | HsInline Activation | HsUnfold IfaceExpr | HsNoCafRefs - | HsWorker IfaceExtName Arity -- Worker, if any see IdInfo.WorkerInfo + | HsWorker Name Arity -- Worker, if any see IdInfo.WorkerInfo -- for why we want arity here. -- NB: we need IfaceExtName (not just OccName) because the worker -- can simplify to a function in another module. @@ -196,7 +204,7 @@ data IfaceInfoItem -------------------------------- data IfaceExpr = IfaceLcl FastString - | IfaceExt IfaceExtName + | IfaceExt Name | IfaceType IfaceType | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr @@ -218,25 +226,80 @@ type IfaceAlt = (IfaceConAlt, [FastString], IfaceExpr) -- thus saving bulk in interface files data IfaceConAlt = IfaceDefault - | IfaceDataAlt OccName + | IfaceDataAlt Name | IfaceTupleAlt Boxity | IfaceLitAlt Literal data IfaceBinding = IfaceNonRec IfaceIdBndr IfaceExpr | IfaceRec [(IfaceIdBndr, IfaceExpr)] -\end{code} - - -%************************************************************************ -%* * -\subsection[HsCore-print]{Printing Core unfoldings} -%* * -%************************************************************************ ------------------------------ Printing IfaceDecl ------------------------------------ +-- ----------------------------------------------------------------------------- +-- Utils on IfaceSyn + +ifaceDeclSubBndrs :: IfaceDecl -> [OccName] +-- *Excludes* the 'main' name, but *includes* the implicitly-bound names +-- Deeply revolting, because it has to predict what gets bound, +-- especially the question of whether there's a wrapper for a datacon + +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) + = co_occs ++ + [tc_occ, dc_occ, dcww_occ] ++ + [op | IfaceClassOp op _ _ <- sigs] ++ + [ifName at | at <- ats ] ++ + [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] + where + n_ctxt = length sc_ctxt + n_sigs = length sigs + tc_occ = mkClassTyConOcc cls_occ + dc_occ = mkClassDataConOcc cls_occ + co_occs | is_newtype = [mkNewTyCoOcc tc_occ] + | otherwise = [] + dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker + | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper + is_newtype = n_sigs + n_ctxt == 1 -- Sigh + +ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} + = [] +-- Newtype +ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, + ifCons = IfNewTyCon ( + IfCon { ifConOcc = con_occ, + ifConFields = fields + }), + ifFamInst = famInst}) + = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ] + ++ famInstCo famInst tc_occ + +ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, + ifCons = IfDataTyCon cons, + ifFamInst = famInst}) + = nub (concatMap ifConFields cons) -- Eliminate duplicate fields + ++ concatMap dc_occs cons + ++ famInstCo famInst tc_occ + where + dc_occs con_decl + | has_wrapper = [con_occ, work_occ, wrap_occ] + | otherwise = [con_occ, work_occ] + where + con_occ = ifConOcc con_decl + strs = ifConStricts con_decl + wrap_occ = mkDataConWrapperOcc con_occ + work_occ = mkDataConWorkerOcc con_occ + has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) + || not (null . ifConEqSpec $ con_decl) + || isJust famInst + -- ToDo: may miss strictness in existential dicts + +ifaceDeclSubBndrs _other = [] + +-- coercion for data/newtype family instances +famInstCo Nothing baseOcc = [] +famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] + +----------------------------- Printing IfaceDecl ------------------------------ -\begin{code} instance Outputable IfaceDecl where ppr = pprIfaceDecl @@ -319,9 +382,10 @@ pprIfaceConDecl tc eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) | (tv,ty) <- eq_spec] con_tau = foldr1 IfaceFunTy (arg_tys ++ [tc_app]) - tc_app = IfaceTyConApp (IfaceTc (LocalTop tc)) + tc_app = IfaceTyConApp (IfaceTc tc_name) [IfaceTyVar tv | (tv,_) <- univ_tvs] - -- Gruesome, but just for debug print + tc_name = mkInternalName (mkBuiltinUnique 1) tc noSrcLoc + -- Really Gruesome, but just for debug print instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, @@ -457,23 +521,25 @@ ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a %* * %************************************************************************ -Equality over IfaceSyn returns an IfaceEq, not a Bool. The new constructor is -EqBut, which gives the set of *locally-defined* things whose version must be equal -for the whole thing to be equal. So the key function is eqIfExt, which compares -IfaceExtNames. +Equality over IfaceSyn returns an IfaceEq, not a Bool. The new +constructor is EqBut, which gives the set of things whose version must +be equal for the whole thing to be equal. So the key function is +eqIfExt, which compares Names. Of course, equality is also done modulo alpha conversion. \begin{code} -data IfaceEq +data GenIfaceEq a = Equal -- Definitely exactly the same | NotEqual -- Definitely different - | EqBut OccSet -- The same provided these local things have not changed + | EqBut a -- The same provided these Names have not changed + +type IfaceEq = GenIfaceEq NameSet instance Outputable IfaceEq where ppr Equal = ptext SLIT("Equal") ppr NotEqual = ptext SLIT("NotEqual") - ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (occSetElts occset) + ppr (EqBut occset) = ptext SLIT("EqBut") <+> ppr (nameSetToList occset) bool :: Bool -> IfaceEq bool True = Equal @@ -491,23 +557,18 @@ zapEq other = other (&&&) :: IfaceEq -> IfaceEq -> IfaceEq Equal &&& x = x NotEqual &&& x = NotEqual -EqBut occs &&& Equal = EqBut occs -EqBut occs &&& NotEqual = NotEqual -EqBut occs1 &&& EqBut occs2 = EqBut (occs1 `unionOccSets` occs2) +EqBut nms &&& Equal = EqBut nms +EqBut nms &&& NotEqual = NotEqual +EqBut nms1 &&& EqBut nms2 = EqBut (nms1 `unionNameSets` nms2) ---------------------- -eqIfExt :: IfaceExtName -> IfaceExtName -> IfaceEq -- This function is the core of the EqBut stuff -eqIfExt (ExtPkg mod1 occ1) (ExtPkg mod2 occ2) = bool (mod1==mod2 && occ1==occ2) -eqIfExt (HomePkg mod1 occ1 v1) (HomePkg mod2 occ2 v2) = bool (mod1==mod2 && occ1==occ2 && v1==v2) -eqIfExt (LocalTop occ1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet occ1) -eqIfExt (LocalTopSub occ1 p1) (LocalTop occ2) | occ1 == occ2 = EqBut (unitOccSet p1) -eqIfExt (LocalTopSub occ1 p1) (LocalTopSub occ2 _) | occ1 == occ2 = EqBut (unitOccSet p1) -eqIfExt n1 n2 = NotEqual -\end{code} +-- ASSUMPTION: The left-hand argument is the NEW CODE, and hence +-- any Names in the left-hand arg have the correct parent in them. +eqIfExt :: Name -> Name -> IfaceEq +eqIfExt name1 name2 + | name1 == name2 = EqBut (unitNameSet name1) + | otherwise = NotEqual - -\begin{code} --------------------- checkBootDecl :: IfaceDecl -- The boot decl -> IfaceDecl -- The real decl diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index ee37891aa7..64d88927f6 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -8,9 +8,7 @@ module IfaceType ( IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, - - IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName, - ifaceTyConName, ifaceTyConOccName, + ifaceTyConName, -- Conversion from Type -> IfaceType toIfaceType, toIfacePred, toIfaceContext, @@ -42,50 +40,6 @@ import Outputable import FastString \end{code} - -%************************************************************************ -%* * - IfaceExtName -%* * -%************************************************************************ - -\begin{code} -data IfaceExtName - = ExtPkg Module OccName - -- From an external package; no version # Also used for - -- wired-in things regardless of whether they are home-pkg or - -- not - - | HomePkg ModuleName OccName Version - -- From another module in home package; has version #; in all - -- other respects, HomePkg and ExtPkg are the same. Since this - -- is a home package name, we use ModuleName rather than Module - - | LocalTop OccName -- Top-level from the same module as - -- the enclosing IfaceDecl - - | LocalTopSub -- Same as LocalTop, but for a class method or constr - OccName -- Class-meth/constr name - OccName -- Parent class/datatype name - -- LocalTopSub is written into iface files as LocalTop; the parent - -- info is only used when computing version information in MkIface - -isLocalIfaceExtName :: IfaceExtName -> Bool -isLocalIfaceExtName (LocalTop _) = True -isLocalIfaceExtName (LocalTopSub _ _) = True -isLocalIfaceExtName other = False - -mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name) - -- Local helper for wired-in names - -ifaceExtOcc :: IfaceExtName -> OccName -ifaceExtOcc (ExtPkg _ occ) = occ -ifaceExtOcc (HomePkg _ occ _) = occ -ifaceExtOcc (LocalTop occ) = occ -ifaceExtOcc (LocalTopSub occ _) = occ -\end{code} - - %************************************************************************ %* * Local (nested) binders @@ -115,7 +69,7 @@ data IfaceType | IfaceFunTy IfaceType IfaceType data IfacePredType -- NewTypes are handled as ordinary TyConApps - = IfaceClassP IfaceExtName [IfaceType] + = IfaceClassP Name [IfaceType] | IfaceIParam (IPName OccName) IfaceType | IfaceEqPred IfaceType IfaceType @@ -124,14 +78,14 @@ type IfaceContext = [IfacePredType] -- NB: If you add a data constructor, remember to add a case to -- IfaceSyn.eqIfTc! data IfaceTyCon -- Abbreviations for common tycons with known names - = IfaceTc IfaceExtName -- The common case + = IfaceTc Name -- The common case | IfaceIntTc | IfaceBoolTc | IfaceCharTc | IfaceListTc | IfacePArrTc | IfaceTupTc Boxity Arity | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc | IfaceUbxTupleKindTc | IfaceArgTypeKindTc -ifaceTyConName :: IfaceTyCon -> Name -- Works for all except IfaceTc +ifaceTyConName :: IfaceTyCon -> Name ifaceTyConName IfaceIntTc = intTyConName ifaceTyConName IfaceBoolTc = boolTyConName ifaceTyConName IfaceCharTc = charTyConName @@ -143,11 +97,7 @@ ifaceTyConName IfaceOpenTypeKindTc = openTypeKindTyConName ifaceTyConName IfaceUnliftedTypeKindTc = unliftedTypeKindTyConName ifaceTyConName IfaceUbxTupleKindTc = ubxTupleKindTyConName ifaceTyConName IfaceArgTypeKindTc = argTypeKindTyConName -ifaceTyConName (IfaceTc ext) = pprPanic "ifaceTyConName" (ppr ext) - -ifaceTyConOccName :: IfaceTyCon -> OccName -- Works for all! -ifaceTyConOccName (IfaceTc ext) = ifaceExtOcc ext -ifaceTyConOccName tycon = nameOccName . ifaceTyConName $ tycon +ifaceTyConName (IfaceTc ext) = ext \end{code} @@ -209,16 +159,6 @@ maybeParen ctxt_prec inner_prec pretty ----------------------------- Printing binders ------------------------------------ \begin{code} --- These instances are used only when printing for the user, either when --- debugging, or in GHCi when printing the results of a :info command -instance Outputable IfaceExtName where - ppr (ExtPkg mod occ) = ppr mod <> dot <> ppr occ - ppr (HomePkg mod occ vers) = ppr mod <> dot <> ppr occ <> braces (ppr vers) - ppr (LocalTop occ) = ppr occ -- Do we want to distinguish these - ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence? --- No need to worry about printing unqualified becuase that was handled --- in the transiation to IfaceSyn - instance Outputable IfaceBndr where ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr ppr (IfaceTvBndr bndr) = char '@' <+> pprIfaceTvBndr bndr @@ -301,7 +241,7 @@ ppr_tc_app ctxt_prec tc tys ppr_tc :: IfaceTyCon -> SDoc -- Wrap infix type constructors in parens -ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (ifaceExtOcc ext_nm) (ppr tc) +ppr_tc tc@(IfaceTc ext_nm) = parenSymOcc (getOccName ext_nm) (ppr tc) ppr_tc tc = ppr tc ------------------- @@ -309,7 +249,7 @@ instance Outputable IfacePredType where -- Print without parens ppr (IfaceEqPred ty1 ty2)= hsep [ppr ty1, ptext SLIT(":=:"), ppr ty2] ppr (IfaceIParam ip ty) = hsep [ppr ip, dcolon, ppr ty] - ppr (IfaceClassP cls ts) = parenSymOcc (ifaceExtOcc cls) (ppr cls) + ppr (IfaceClassP cls ts) = parenSymOcc (getOccName cls) (ppr cls) <+> sep (map pprParendIfaceType ts) instance Outputable IfaceTyCon where @@ -338,26 +278,32 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \begin{code} ---------------- toIfaceTvBndr tyvar = (occNameFS (getOccName tyvar), toIfaceKind (tyVarKind tyvar)) -toIfaceIdBndr ext id = (occNameFS (getOccName id), toIfaceType ext (idType id)) +toIfaceIdBndr id = (occNameFS (getOccName id), toIfaceType (idType id)) toIfaceTvBndrs tyvars = map toIfaceTvBndr tyvars -toIfaceBndr ext var - | isId var = IfaceIdBndr (toIfaceIdBndr ext var) +toIfaceBndr var + | isId var = IfaceIdBndr (toIfaceIdBndr var) | otherwise = IfaceTvBndr (toIfaceTvBndr var) --- we had better not have to use ext for kinds -toIfaceKind = toIfaceType (\name -> pprPanic "toIfaceKind ext used on:" (ppr name)) +toIfaceKind = toIfaceType --------------------- -toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType +toIfaceType :: Type -> IfaceType -- Synonyms are retained in the interface type -toIfaceType ext (TyVarTy tv) = IfaceTyVar (occNameFS (getOccName tv)) -toIfaceType ext (AppTy t1 t2) = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2) -toIfaceType ext (FunTy t1 t2) = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2) -toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon ext tc) (toIfaceTypes ext tys) -toIfaceType ext (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t) -toIfaceType ext (PredTy st) = IfacePredTy (toIfacePred ext st) -toIfaceType ext (NoteTy other_note ty) = toIfaceType ext ty +toIfaceType (TyVarTy tv) = + IfaceTyVar (occNameFS (getOccName tv)) +toIfaceType (AppTy t1 t2) = + IfaceAppTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (FunTy t1 t2) = + IfaceFunTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (TyConApp tc tys) = + IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) +toIfaceType (ForAllTy tv t) = + IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) +toIfaceType (PredTy st) = + IfacePredTy (toIfacePred st) +toIfaceType (NoteTy other_note ty) = + toIfaceType ty ---------------- -- A little bit of (perhaps optional) trickiness here. When @@ -367,20 +313,20 @@ toIfaceType ext (NoteTy other_note ty) = toIfaceType ext ty -- Hence a tuple tycon may 'miss' in toIfaceTyCon, but then -- toIfaceTyCon_name will still catch it. -toIfaceTyCon :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon -toIfaceTyCon ext tc +toIfaceTyCon :: TyCon -> IfaceTyCon +toIfaceTyCon tc | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) - | otherwise = toIfaceTyCon_name ext (tyConName tc) + | otherwise = toIfaceTyCon_name (tyConName tc) -toIfaceTyCon_name :: (Name -> IfaceExtName) -> Name -> IfaceTyCon -toIfaceTyCon_name ext nm +toIfaceTyCon_name :: Name -> IfaceTyCon +toIfaceTyCon_name nm | Just (ATyCon tc) <- wiredInNameTyThing_maybe nm - = toIfaceWiredInTyCon ext tc nm + = toIfaceWiredInTyCon tc nm | otherwise - = IfaceTc (ext nm) + = IfaceTc nm -toIfaceWiredInTyCon :: (Name -> IfaceExtName) -> TyCon -> Name -> IfaceTyCon -toIfaceWiredInTyCon ext tc nm +toIfaceWiredInTyCon :: TyCon -> Name -> IfaceTyCon +toIfaceWiredInTyCon tc nm | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) | nm == intTyConName = IfaceIntTc | nm == boolTyConName = IfaceBoolTc @@ -392,18 +338,21 @@ toIfaceWiredInTyCon ext tc nm | nm == openTypeKindTyConName = IfaceOpenTypeKindTc | nm == argTypeKindTyConName = IfaceArgTypeKindTc | nm == ubxTupleKindTyConName = IfaceUbxTupleKindTc - | otherwise = IfaceTc (ext nm) + | otherwise = IfaceTc nm ---------------- -toIfaceTypes ext ts = map (toIfaceType ext) ts +toIfaceTypes ts = map toIfaceType ts ---------------- -toIfacePred ext (ClassP cls ts) = IfaceClassP (ext (getName cls)) (toIfaceTypes ext ts) -toIfacePred ext (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (toIfaceType ext t) -toIfacePred ext (EqPred ty1 ty2) = IfaceEqPred (toIfaceType ext ty1) (toIfaceType ext ty2) +toIfacePred (ClassP cls ts) = + IfaceClassP (getName cls) (toIfaceTypes ts) +toIfacePred (IParam ip t) = + IfaceIParam (mapIPName getOccName ip) (toIfaceType t) +toIfacePred (EqPred ty1 ty2) = + IfaceEqPred (toIfaceType ty1) (toIfaceType ty2) ---------------- -toIfaceContext :: (Name -> IfaceExtName) -> ThetaType -> IfaceContext -toIfaceContext ext cs = map (toIfacePred ext) cs +toIfaceContext :: ThetaType -> IfaceContext +toIfaceContext cs = map toIfacePred cs \end{code} diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index e322276dea..5b19c894fa 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -11,7 +11,7 @@ module LoadIface ( loadDecls, -- Should move to TcIface and be renamed initExternalPackageState, - ifaceStats, pprModIface, showIface -- Print the iface in Foo.hi + ifaceStats, pprModIface, showIface ) where #include "HsVersions.h" @@ -20,9 +20,8 @@ import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, tcIfaceFamInst ) import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) -import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), - IfaceConDecls(..), IfaceFamInst(..) ) -import IfaceEnv ( newGlobalBinder, lookupIfaceTc ) +import IfaceSyn +import IfaceEnv ( newGlobalBinder ) import HscTypes ( ModIface(..), TyThing, IfaceExport, Usage(..), Deprecs(..), Dependencies(..), emptyModIface, EpsStats(..), GenAvailInfo(..), @@ -62,8 +61,8 @@ import UniqFM import StaticFlags ( opt_HiVersion ) import Outputable import BinIface ( readBinIface, v_IgnoreHiWay ) -import Binary ( getBinFileWithDict ) -import Panic ( ghcError, tryMost, showException, GhcException(..) ) +import Binary +import Panic ( ghcError, showException, GhcException(..) ) import List ( nub ) import Maybe ( isJust ) import DATA_IOREF ( writeIORef ) @@ -306,12 +305,9 @@ loadDecl :: Bool -- Don't load pragmas into the decl pool loadDecl ignore_prags mod (_version, decl) = do { -- Populate the name cache with final versions of all -- the names associated with the decl - main_name <- mk_new_bndr mod Nothing (ifName decl) - ; parent_name <- case ifFamily decl of -- make family the parent - Just famTyCon -> lookupIfaceTc famTyCon - _ -> return main_name - ; implicit_names <- mapM (mk_new_bndr mod (Just parent_name)) - (ifaceDeclSubBndrs decl) + main_name <- mk_new_bndr mod (ifName decl) + ; traceIf (text "Loading decl for " <> ppr main_name) + ; implicit_names <- mapM (mk_new_bndr mod) (ifaceDeclSubBndrs decl) -- Typecheck the thing, lazily -- NB. Firstly, the laziness is there in case we never need the @@ -341,8 +337,8 @@ loadDecl ignore_prags mod (_version, decl) -- * parent -- * location -- imported name, to fix the module correctly in the cache - mk_new_bndr mod mb_parent occ - = newGlobalBinder mod occ mb_parent + mk_new_bndr mod occ + = newGlobalBinder mod occ (importedSrcLoc (showSDoc (ppr (moduleName mod)))) -- ToDo: qualify with the package name if necessary @@ -357,70 +353,6 @@ bumpDeclStats name ; updateEps_ (\eps -> let stats = eps_stats eps in eps { eps_stats = stats { n_decls_out = n_decls_out stats + 1 } }) } - ------------------ -ifaceDeclSubBndrs :: IfaceDecl -> [OccName] --- *Excludes* the 'main' name, but *includes* the implicitly-bound names --- Deeply revolting, because it has to predict what gets bound, --- especially the question of whether there's a wrapper for a datacon --- --- If you change this, make sure you change HscTypes.implicitTyThings in sync - -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, - ifSigs = sigs, ifATs = ats }) - = co_occs ++ - [tc_occ, dc_occ, dcww_occ] ++ - [op | IfaceClassOp op _ _ <- sigs] ++ - [ifName at | at <- ats ] ++ - [mkSuperDictSelOcc n cls_occ | n <- [1..n_ctxt]] - where - n_ctxt = length sc_ctxt - n_sigs = length sigs - tc_occ = mkClassTyConOcc cls_occ - dc_occ = mkClassDataConOcc cls_occ - co_occs | is_newtype = [mkNewTyCoOcc tc_occ] - | otherwise = [] - dcww_occ -- | is_newtype = mkDataConWrapperOcc dc_occ -- Newtypes have wrapper but no worker - | otherwise = mkDataConWorkerOcc dc_occ -- Otherwise worker but no wrapper - is_newtype = n_sigs + n_ctxt == 1 -- Sigh - -ifaceDeclSubBndrs IfaceData {ifCons = IfAbstractTyCon} - = [] --- Newtype -ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, - ifCons = IfNewTyCon ( - IfCon { ifConOcc = con_occ, - ifConFields = fields - }), - ifFamInst = famInst}) - = fields ++ [con_occ, mkDataConWorkerOcc con_occ, mkNewTyCoOcc tc_occ] - ++ famInstCo famInst tc_occ - -ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, - ifCons = IfDataTyCon cons, - ifFamInst = famInst}) - = nub (concatMap ifConFields cons) -- Eliminate duplicate fields - ++ concatMap dc_occs cons - ++ famInstCo famInst tc_occ - where - dc_occs con_decl - | has_wrapper = [con_occ, work_occ, wrap_occ] - | otherwise = [con_occ, work_occ] - where - con_occ = ifConOcc con_decl - strs = ifConStricts con_decl - wrap_occ = mkDataConWrapperOcc con_occ - work_occ = mkDataConWorkerOcc con_occ - has_wrapper = any isMarkedStrict strs -- See MkId.mkDataConIds (sigh) - || not (null . ifConEqSpec $ con_decl) - || isJust famInst - -- ToDo: may miss strictness in existential dicts - -ifaceDeclSubBndrs _other = [] - --- coercion for data/newtype family instances -famInstCo Nothing baseOcc = [] -famInstCo (Just _) baseOcc = [mkInstTyCoOcc baseOcc] \end{code} @@ -504,8 +436,7 @@ readIface :: Module -> FilePath -> IsBootInterface readIface wanted_mod file_path is_hi_boot_file = do { dflags <- getDOpts - ; ioToIOEnv $ do - { res <- tryMost (readBinIface file_path) + ; res <- tryMostM $ readBinIface file_path ; case res of Right iface | wanted_mod == actual_mod -> return (Succeeded iface) @@ -515,7 +446,7 @@ readIface wanted_mod file_path is_hi_boot_file err = hiModuleNameMismatchWarn wanted_mod actual_mod Left exn -> return (Failed (text (showException exn))) - }} + } \end{code} @@ -594,18 +525,16 @@ ifaceStats eps %************************************************************************ \begin{code} -showIface :: FilePath -> IO () --- Read binary interface, and print it out -showIface filename = do +-- | Read binary interface, and print it out +showIface :: HscEnv -> FilePath -> IO () +showIface hsc_env filename = do -- skip the version check; we don't want to worry about profiled vs. -- non-profiled interfaces, for example. writeIORef v_IgnoreHiWay True - iface <- Binary.getBinFileWithDict filename + iface <- initTcRnIf 's' hsc_env () () $ readBinIface filename printDump (pprModIface iface) - where \end{code} - \begin{code} pprModIface :: ModIface -> SDoc -- Show a ModIface diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 11235cef2e..e99e8bf038 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -176,8 +176,7 @@ compiled with -O. I think this is the case.] #include "HsVersions.h" import IfaceSyn -- All of it -import IfaceType ( toIfaceTvBndrs, toIfaceType, toIfaceContext, - ifaceTyConOccName ) +import IfaceType import LoadIface ( readIface, loadInterface, pprModIface ) import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), @@ -209,41 +208,43 @@ import HscTypes ( ModIface(..), ModDetails(..), ModSummary(..), msHiFilePath, mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, typeEnvElts, - GenAvailInfo(..), availName, + GenAvailInfo(..), availName, AvailInfo, ExternalPackageState(..), Usage(..), IsBootInterface, Deprecs(..), IfaceDeprecs, Deprecations, - lookupIfaceByModule + lookupIfaceByModule, isImplicitTyThing ) import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt ) -import Name ( Name, nameModule, nameOccName, nameParent, - isExternalName, isInternalName, nameParent_maybe, isWiredInName, - isImplicitName, NamedThing(..) ) +import Name ( Name, nameModule, nameModule_maybe, nameOccName, + isExternalName, isInternalName, isWiredInName, + NamedThing(..) ) import NameEnv import NameSet import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv_C, OccSet, emptyOccSet, elemOccSet, occSetElts, - extendOccSet, extendOccSetList, + extendOccSet, extendOccSetList, mkOccSet, isEmptyOccSet, intersectOccSet, intersectsOccSet, + unionOccSets, unitOccSet, occNameFS, isTcOcc ) import Module -import Outputable -import BasicTypes ( Version, initialVersion, bumpVersion, isAlwaysActive, - Activation(..), RecFlag(..), boolToRecFlag ) -import Util ( createDirectoryHierarchy, directoryOf, sortLe, seqList, lengthIs ) -import BinIface ( writeBinIface ) +import BinIface ( readBinIface, writeBinIface, v_IgnoreHiWay ) import Unique ( Unique, Uniquable(..) ) import ErrUtils ( dumpIfSet_dyn, showPass ) import Digraph ( stronglyConnComp, SCC(..) ) import SrcLoc ( SrcSpan ) -import UniqFM import PackageConfig ( PackageId ) +import Outputable +import BasicTypes hiding ( SuccessFlag(..) ) +import UniqFM +import Util hiding ( eqListBy ) import FiniteMap import FastString +import Data.List ( partition ) +import DATA_IOREF ( writeIORef ) import Monad ( when ) import List ( insert ) import Maybes ( orElse, mapCatMaybes, isNothing, isJust, @@ -287,24 +288,20 @@ mkIface hsc_env maybe_old_iface -- to expose in the interface = do { eps <- hscEPS hsc_env - ; let { ext_nm_rhs = mkExtNameFn hsc_env eps this_mod - ; ext_nm_lhs = mkLhsNameFn this_mod - - ; decls = [ tyThingToIfaceDecl ext_nm_rhs thing - | thing <- typeEnvElts type_env, - let name = getName thing, - not (isImplicitName name || isWiredInName name) ] - -- Don't put implicit Ids and class tycons in the interface file - -- Nor wired-in things; the compiler knows about them anyhow - - ; fixities = [ (occ,fix) - | FixItem occ fix _ <- nameEnvElts fix_env] - ; deprecs = mkIfaceDeprec src_deprecs - ; iface_rules = map (coreRuleToIfaceRule - ext_nm_lhs ext_nm_rhs) rules - ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts - ; iface_fam_insts = map (famInstToIfaceFamInst ext_nm_lhs) - fam_insts + ; let { entities = typeEnvElts type_env ; + decls = [ tyThingToIfaceDecl entity + | entity <- entities, + not (isImplicitTyThing entity + || isWiredInName (getName entity)) ] + -- Don't put implicit Ids and class tycons in + -- the interface file, Nor wired-in things; the + -- compiler knows about them anyhow + + ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] + ; deprecs = mkIfaceDeprec src_deprecs + ; iface_rules = map coreRuleToIfaceRule rules + ; iface_insts = map instanceToIfaceInst insts + ; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; intermediate_iface = ModIface { mi_module = this_mod, @@ -333,9 +330,11 @@ mkIface hsc_env maybe_old_iface mi_fix_fn = mkIfaceFixCache fixities } -- Add version information + ; ext_ver_fn = mkParentVerFun hsc_env eps ; (new_iface, no_change_at_all, pp_diffs, pp_orphs) = _scc_ "versioninfo" - addVersionInfo maybe_old_iface intermediate_iface decls + addVersionInfo ext_ver_fn maybe_old_iface + intermediate_iface decls } -- Debug printing @@ -353,87 +352,61 @@ mkIface hsc_env maybe_old_iface dflags = hsc_dflags hsc_env deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) - ifFamInstTyConOcc = ifaceTyConOccName . ifFamInstTyCon + ifFamInstTyConOcc = nameOccName . ifaceTyConName . ifFamInstTyCon ----------------------------- -writeIfaceFile :: ModLocation -> ModIface -> IO () -writeIfaceFile location new_iface +writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () +writeIfaceFile dflags location new_iface = do createDirectoryHierarchy (directoryOf hi_file_path) - writeBinIface hi_file_path new_iface + writeBinIface dflags hi_file_path new_iface where hi_file_path = ml_hi_file location ------------------------------ -mkExtNameFn :: HscEnv -> ExternalPackageState -> Module -> Name -> IfaceExtName -mkExtNameFn hsc_env eps this_mod - = ext_nm - where - hpt = hsc_HPT hsc_env - pit = eps_PIT eps - - ext_nm name - | mod == this_mod = case nameParent_maybe name of - Nothing -> LocalTop occ - Just par -> LocalTopSub occ (nameOccName par) - | isWiredInName name = ExtPkg mod occ - | is_home mod = HomePkg mod_name occ vers - | otherwise = ExtPkg mod occ - where - dflags = hsc_dflags hsc_env - this_pkg = thisPackage dflags - is_home mod = modulePackageId mod == this_pkg - - mod = nameModule name - mod_name = moduleName mod - occ = nameOccName name - par_occ = nameOccName (nameParent name) - -- The version of the *parent* is the one want - vers = lookupVersion mod par_occ occ - - lookupVersion :: Module -> OccName -> OccName -> Version - -- Even though we're looking up a home-package thing, in - -- one-shot mode the imported interfaces may be in the PIT - lookupVersion mod par_occ occ - = mi_ver_fn iface par_occ `orElse` - pprPanic "lookupVers1" (ppr mod <+> ppr par_occ <+> ppr occ) - where - iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` - pprPanic "lookupVers2" (ppr mod <+> ppr par_occ <+> ppr occ) +-- ----------------------------------------------------------------------------- +-- Look up parents and versions of Names +-- This is like a global version of the mi_ver_fn field in each ModIface. +-- Given a Name, it finds the ModIface, and then uses mi_ver_fn to get +-- the parent and version info. ---------------------- --- mkLhsNameFn ignores versioning info altogether --- It is used for the LHS of instance decls and rules, where we --- there's no point in recording version info -mkLhsNameFn :: Module -> Name -> IfaceExtName -mkLhsNameFn this_mod name - | isInternalName name = pprTrace "mkLhsNameFn: unexpected internal" (ppr name) $ - LocalTop occ -- Should not happen - | mod == this_mod = LocalTop occ - | otherwise = ExtPkg mod occ +mkParentVerFun + :: HscEnv -- needed to look up versions + -> ExternalPackageState -- ditto + -> (Name -> (OccName,Version)) +mkParentVerFun hsc_env eps + = \name -> + let + mod = nameModule name + occ = nameOccName name + iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` + pprPanic "lookupVers2" (ppr mod <+> ppr occ) + in + mi_ver_fn iface occ `orElse` + pprPanic "lookupVers1" (ppr mod <+> ppr occ) where - mod = nameModule name - occ = nameOccName name - + hpt = hsc_HPT hsc_env + pit = eps_PIT eps ------------------------------ +----------------------------------------------------------------------------- -- Compute version numbers for local decls -addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi - -> ModIface -- The new interface decls (lacking decls) - -> [IfaceDecl] -- The new decls - -> (ModIface, - Bool, -- True <=> no changes at all; no need to write new Iface - SDoc, -- Differences - Maybe SDoc) -- Warnings about orphans - -addVersionInfo Nothing new_iface new_decls +addVersionInfo + :: (Name -> (OccName,Version)) -- lookup parents and versions of names + -> Maybe ModIface -- The old interface, read from M.hi + -> ModIface -- The new interface (lacking decls) + -> [IfaceDecl] -- The new decls + -> (ModIface, -- Updated interface + Bool, -- True <=> no changes at all; no need to write Iface + SDoc, -- Differences + Maybe SDoc) -- Warnings about orphans + +addVersionInfo ver_fn Nothing new_iface new_decls -- No old interface, so definitely write a new one! = (new_iface { mi_orphan = anyNothing ifInstOrph (mi_insts new_iface) - || anyNothing ifRuleOrph (mi_rules new_iface), - mi_decls = [(initialVersion, decl) | decl <- new_decls], - mi_ver_fn = \n -> Just initialVersion }, + || anyNothing ifRuleOrph (mi_rules new_iface), + mi_decls = [(initialVersion, decl) | decl <- new_decls], + mi_ver_fn = mkIfaceVerCache (zip (repeat initialVersion) new_decls)}, False, ptext SLIT("No old interface file"), pprOrphans orph_insts orph_rules) @@ -441,7 +414,8 @@ addVersionInfo Nothing new_iface new_decls orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface) orph_rules = filter (isNothing . ifRuleOrph) (mi_rules new_iface) -addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, +addVersionInfo ver_fn (Just old_iface@(ModIface { + mi_mod_vers = old_mod_vers, mi_exp_vers = old_exp_vers, mi_rule_vers = old_rule_vers, mi_decls = old_decls, @@ -449,29 +423,35 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, mi_fix_fn = old_fixities })) new_iface@(ModIface { mi_fix_fn = new_fixities }) new_decls - - | no_change_at_all = (old_iface, True, ptext SLIT("Interface file unchanged"), pp_orphs) - | otherwise = (final_iface, False, vcat [ptext SLIT("Interface file has changed"), - nest 2 pp_diffs], pp_orphs) - where - final_iface = new_iface { mi_mod_vers = bump_unless no_output_change old_mod_vers, - mi_exp_vers = bump_unless no_export_change old_exp_vers, - mi_rule_vers = bump_unless no_rule_change old_rule_vers, - mi_orphan = not (null new_orph_rules && null new_orph_insts), - mi_decls = decls_w_vers, - mi_ver_fn = mkIfaceVerCache decls_w_vers } + | no_change_at_all + = (old_iface, True, ptext SLIT("Interface file unchanged"), pp_orphs) + | otherwise + = (final_iface, False, vcat [ptext SLIT("Interface file has changed"), + nest 2 pp_diffs], pp_orphs) + where + final_iface = new_iface { + mi_mod_vers = bump_unless no_output_change old_mod_vers, + mi_exp_vers = bump_unless no_export_change old_exp_vers, + mi_rule_vers = bump_unless no_rule_change old_rule_vers, + mi_orphan = not (null new_orph_rules && null new_orph_insts), + mi_decls = decls_w_vers, + mi_ver_fn = mkIfaceVerCache decls_w_vers } decls_w_vers = [(add_vers decl, decl) | decl <- new_decls] ------------------- - (old_non_orph_insts, old_orph_insts) = mkOrphMap ifInstOrph (mi_insts old_iface) - (new_non_orph_insts, new_orph_insts) = mkOrphMap ifInstOrph (mi_insts new_iface) + (old_non_orph_insts, old_orph_insts) = + mkOrphMap ifInstOrph (mi_insts old_iface) + (new_non_orph_insts, new_orph_insts) = + mkOrphMap ifInstOrph (mi_insts new_iface) same_insts occ = eqMaybeBy (eqListBy eqIfInst) (lookupOccEnv old_non_orph_insts occ) (lookupOccEnv new_non_orph_insts occ) - (old_non_orph_rules, old_orph_rules) = mkOrphMap ifRuleOrph (mi_rules old_iface) - (new_non_orph_rules, new_orph_rules) = mkOrphMap ifRuleOrph (mi_rules new_iface) + (old_non_orph_rules, old_orph_rules) = + mkOrphMap ifRuleOrph (mi_rules old_iface) + (new_non_orph_rules, new_orph_rules) = + mkOrphMap ifRuleOrph (mi_rules new_iface) same_rules occ = eqMaybeBy (eqListBy eqIfRule) (lookupOccEnv old_non_orph_rules occ) (lookupOccEnv new_non_orph_rules occ) @@ -479,10 +459,11 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, -- Computing what changed no_output_change = no_decl_change && no_rule_change && no_export_change && no_deprec_change - no_export_change = mi_exports new_iface == mi_exports old_iface -- Kept sorted + no_export_change = mi_exports new_iface == mi_exports old_iface + -- Kept sorted no_decl_change = isEmptyOccSet changed_occs - no_rule_change = not (changedWrt changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules) - || changedWrt changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)) + no_rule_change = not (changedWrtNames changed_occs (eqListBy eqIfRule old_orph_rules new_orph_rules) + || changedWrtNames changed_occs (eqListBy eqIfInst old_orph_insts new_orph_insts)) no_deprec_change = mi_deprecs new_iface == mi_deprecs old_iface -- If the usages havn't changed either, we don't need to write the interface file @@ -506,28 +487,32 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, ------------------- -- Adding version info - new_version = bumpVersion old_mod_vers -- Start from the old module version, not from zero - -- so that if you remove f, and then add it again, - -- you don't thereby reduce f's version number + new_version = bumpVersion old_mod_vers + -- Start from the old module version, not from + -- zero so that if you remove f, and then add + -- it again, you don't thereby reduce f's + -- version number + add_vers decl | occ `elemOccSet` changed_occs = new_version - | otherwise = expectJust "add_vers" (old_decl_vers occ) + | otherwise = snd (expectJust "add_vers" (old_decl_vers occ)) -- If it's unchanged, there jolly well where -- should be an old version number occ = ifName decl ------------------- - changed_occs :: OccSet - changed_occs = computeChangedOccs eq_info - + -- Deciding which declarations have changed + + -- For each local decl, the IfaceEq gives the list of things that + -- must be unchanged for the declaration as a whole to be unchanged. eq_info :: [(OccName, IfaceEq)] eq_info = map check_eq new_decls - check_eq new_decl | Just old_decl <- lookupOccEnv old_decl_env occ - = (occ, new_decl `eqIfDecl` old_decl &&& - eq_indirects new_decl) - | otherwise {- No corresponding old decl -} - = (occ, NotEqual) - where - occ = ifName new_decl + check_eq new_decl + | Just old_decl <- lookupOccEnv old_decl_env occ + = (occ, new_decl `eqIfDecl` old_decl &&& eq_indirects new_decl) + | otherwise {- No corresponding old decl -} + = (occ, NotEqual) + where + occ = ifName new_decl eq_indirects :: IfaceDecl -> IfaceEq -- When seeing if two decls are the same, remember to @@ -544,7 +529,12 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, eq_ind_occ :: OccName -> IfaceEq -- For class ops and Ids; check fixity and rules eq_ind_occ occ = same_fixity occ &&& same_rules occ eq_ind_occs = foldr ((&&&) . eq_ind_occ) Equal - + + -- The Occs of declarations that changed. + changed_occs :: OccSet + changed_occs = computeChangedOccs ver_fn (mi_module new_iface) + (mi_usages old_iface) eq_info + ------------------- -- Diffs pp_decl_diffs :: SDoc -- Nothing => no changes @@ -564,9 +554,10 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, where occ = ifName new_decl why = case lookupOccEnv eq_env occ of - Just (EqBut occs) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:"), + Just (EqBut names) -> sep [ppr occ <> colon, ptext SLIT("Free vars (only) changed:"), nest 2 (braces (fsep (map ppr (occSetElts (occs `intersectOccSet` changed_occs)))))] + where occs = mkOccSet (map nameOccName (nameSetToList names)) Just NotEqual | Just old_decl <- lookupOccEnv old_decl_env occ -> vcat [ptext SLIT("Old:") <+> ppr old_decl, @@ -577,6 +568,7 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, pp_orphs = pprOrphans new_orph_insts new_orph_rules + pprOrphans insts rules | null insts && null rules = Nothing | otherwise @@ -589,32 +581,82 @@ pprOrphans insts rules 2 (vcat (map ppr rules)) ] -computeChangedOccs :: [(OccName, IfaceEq)] -> OccSet -computeChangedOccs eq_info +computeChangedOccs + :: (Name -> (OccName,Version)) -- get parents and versions + -> Module -- This module + -> [Usage] -- Usages from old iface + -> [(OccName, IfaceEq)] -- decl names, equality conditions + -> OccSet -- set of things that have changed +computeChangedOccs ver_fn this_module old_usages eq_info = foldl add_changes emptyOccSet (stronglyConnComp edges) where - edges :: [((OccName,IfaceEq), Unique, [Unique])] + + -- return True if an external name has changed + name_changed :: Name -> Bool + name_changed nm + | Just ents <- lookupUFM usg_modmap (moduleName mod) + = case lookupUFM ents parent_occ of + Nothing -> pprPanic "computeChangedOccs" (ppr nm) + Just v -> v < new_version + | otherwise = False -- must be in another package + where + mod = nameModule nm + (parent_occ, new_version) = ver_fn nm + + -- Turn the usages from the old ModIface into a mapping + usg_modmap = listToUFM [ (usg_mod usg, listToUFM (usg_entities usg)) + | usg <- old_usages ] + + get_local_eq_info :: GenIfaceEq NameSet -> GenIfaceEq OccSet + get_local_eq_info Equal = Equal + get_local_eq_info NotEqual = NotEqual + get_local_eq_info (EqBut ns) = foldNameSet f Equal ns + where f name eq | nameModule name == this_module = + EqBut (unitOccSet (nameOccName name)) `and_occifeq` eq + | name_changed name = NotEqual + | otherwise = eq + + local_eq_infos = mapSnd get_local_eq_info eq_info + + edges :: [((OccName, OccIfaceEq), Unique, [Unique])] edges = [ (node, getUnique occ, map getUnique occs) - | node@(occ, iface_eq) <- eq_info + | node@(occ, iface_eq) <- local_eq_infos , let occs = case iface_eq of EqBut occ_set -> occSetElts occ_set other -> [] ] -- Changes in declarations - add_changes :: OccSet -> SCC (OccName, IfaceEq) -> OccSet + add_changes :: OccSet -> SCC (OccName, OccIfaceEq) -> OccSet add_changes so_far (AcyclicSCC (occ, iface_eq)) - | changedWrt so_far iface_eq -- This one has changed + | changedWrt so_far iface_eq -- This one has changed = extendOccSet so_far occ add_changes so_far (CyclicSCC pairs) - | changedWrt so_far (foldr1 (&&&) (map snd pairs)) -- One of this group has changed - = extendOccSetList so_far (map fst pairs) + | changedWrt so_far (foldr1 and_occifeq iface_eqs) + -- One of this group has changed + = extendOccSetList so_far occs + where (occs, iface_eqs) = unzip pairs add_changes so_far other = so_far -changedWrt :: OccSet -> IfaceEq -> Bool +type OccIfaceEq = GenIfaceEq OccSet + +changedWrt :: OccSet -> OccIfaceEq -> Bool changedWrt so_far Equal = False changedWrt so_far NotEqual = True changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids +changedWrtNames :: OccSet -> IfaceEq -> Bool +changedWrtNames so_far Equal = False +changedWrtNames so_far NotEqual = True +changedWrtNames so_far (EqBut kids) = + so_far `intersectsOccSet` mkOccSet (map nameOccName (nameSetToList kids)) + +and_occifeq :: OccIfaceEq -> OccIfaceEq -> OccIfaceEq +Equal `and_occifeq` x = x +NotEqual `and_occifeq` x = NotEqual +EqBut nms `and_occifeq` Equal = EqBut nms +EqBut nms `and_occifeq` NotEqual = NotEqual +EqBut nms1 `and_occifeq` EqBut nms2 = EqBut (nms1 `unionOccSets` nms2) + ---------------------- -- mkOrphMap partitions instance decls or rules into -- (a) an OccEnv for ones that are not orphans, @@ -672,28 +714,25 @@ mkUsageInfo hsc_env dir_imp_mods dep_mods used_names -- don't get evaluated for a while and we can end up hanging on to -- the entire collection of Ifaces. -mk_usage_info pit hsc_env dir_imp_mods dep_mods proto_used_names +mk_usage_info pit hsc_env dir_imp_mods dep_mods used_names = mapCatMaybes mkUsage dep_mods -- ToDo: do we need to sort into canonical order? where hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env - used_names = mkNameSet $ -- Eliminate duplicates - [ nameParent n -- Just record usage on the 'main' names - | n <- nameSetToList proto_used_names - , not (isWiredInName n) -- Don't record usages for wired-in names - , isExternalName n -- Ignore internal names - ] - -- ent_map groups together all the things imported and used -- from a particular module in this package ent_map :: ModuleEnv [OccName] ent_map = foldNameSet add_mv emptyModuleEnv used_names - add_mv name mv_map = extendModuleEnv_C add_item mv_map mod [occ] + add_mv name mv_map + | isWiredInName name = mv_map -- ignore wired-in names + | otherwise + = case nameModule_maybe name of + Nothing -> mv_map -- ignore internal names + Just mod -> extendModuleEnv_C add_item mv_map mod [occ] where occ = nameOccName name - mod = nameModule name add_item occs _ = occ:occs depend_on_exports mod = case lookupModuleEnv dir_imp_mods mod of @@ -718,7 +757,7 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods proto_used_names = Just (Usage { usg_name = mod_name, usg_mod = mod_vers, usg_exports = export_vers, - usg_entities = ent_vers, + usg_entities = fmToList ent_vers, usg_rules = rules_vers }) where maybe_iface = lookupIfaceByModule dflags hpt pit mod @@ -735,40 +774,48 @@ mk_usage_info pit hsc_env dir_imp_mods dep_mods proto_used_names export_vers | depend_on_exports mod = Just (mi_exp_vers iface) | otherwise = Nothing - -- The sort is to put them into canonical order used_occs = lookupModuleEnv ent_map mod `orElse` [] - ent_vers :: [(OccName,Version)] - ent_vers = [ (occ, version_env occ `orElse` initialVersion) - | occ <- sortLe (<=) used_occs] + + -- Making a FiniteMap here ensures that (a) we remove duplicates + -- when we have usages on several subordinates of a single parent, + -- and (b) that the usages emerge in a canonical order, which + -- is why we use FiniteMap rather than OccEnv: FiniteMap works + -- using Ord on the OccNames, which is a lexicographic ordering. + ent_vers :: FiniteMap OccName Version + ent_vers = listToFM (map lookup_occ used_occs) + + lookup_occ occ = + case version_env occ of + Nothing -> pprTrace "hmm, strange" (ppr mod <+> ppr occ) $ + (occ, initialVersion) -- does this ever happen? + Just (parent, version) -> (parent, version) \end{code} \begin{code} -mkIfaceExports :: NameSet -> [(Module, [GenAvailInfo OccName])] +mkIfaceExports :: [AvailInfo] + -> [(Module, [GenAvailInfo OccName])] -- Group by module and sort by occurrence -- This keeps the list in canonical order -mkIfaceExports exports - = [ (mod, eltsUFM avails) +mkIfaceExports exports + = [ (mod, eltsFM avails) | (mod, avails) <- fmToList groupFM ] where - groupFM :: ModuleEnv (UniqFM (GenAvailInfo OccName)) - -- Deliberately use the FastString so we + -- Deliberately use FiniteMap rather than UniqFM so we -- get a canonical ordering - groupFM = foldl add emptyModuleEnv (nameSetToList exports) + groupFM :: ModuleEnv (FiniteMap FastString (GenAvailInfo OccName)) + groupFM = foldl add emptyModuleEnv exports - add env name = extendModuleEnv_C add_avail env mod - (unitUFM avail_fs avail) + add env avail + = extendModuleEnv_C add_avail env mod (unitFM avail_fs avail_occ) where - occ = nameOccName name - mod = nameModule name - avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ] - | isTcOcc occ = AvailTC occ [occ] - | otherwise = Avail occ - avail_fs = occNameFS (availName avail) - add_avail avail_fm _ = addToUFM_C add_item avail_fm avail_fs avail - - add_item (AvailTC p occs) _ = AvailTC p (List.insert occ occs) - add_item (Avail n) _ = pprPanic "MkIface.addAvail" (ppr n <+> ppr name) + avail_occ = availToOccs avail + mod = nameModule (availName avail) + avail_fs = occNameFS (availName avail_occ) + add_avail avail_fm _ = addToFM avail_fm avail_fs avail_occ + + availToOccs (Avail n) = Avail (nameOccName n) + availToOccs (AvailTC tc ns) = AvailTC (nameOccName tc) (map nameOccName ns) \end{code} @@ -961,7 +1008,7 @@ checkEntityUsage new_vers (name,old_vers) Nothing -> -- We used it before, but it ain't there now out_of_date (sep [ptext SLIT("No longer exported:"), ppr name]) - Just new_vers -- It's there, but is it up to date? + Just (_, new_vers) -- It's there, but is it up to date? | new_vers == old_vers -> traceHiDiffs (text " Up to date" <+> ppr name <+> parens (ppr new_vers)) `thenM_` returnM upToDate | otherwise -> out_of_date_vers (ptext SLIT(" Out of date:") <+> ppr name) @@ -990,26 +1037,26 @@ checkList (check:checks) = check `thenM` \ recompile -> %************************************************************************ \begin{code} -tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl +tyThingToIfaceDecl :: TyThing -> IfaceDecl -- Assumption: the thing is already tidied, so that locally-bound names -- (lambdas, for-alls) already have non-clashing OccNames -- Reason: Iface stuff uses OccNames, and the conversion here does -- not do tidying on the way -tyThingToIfaceDecl ext (AnId id) - = IfaceId { ifName = getOccName id, - ifType = toIfaceType ext (idType id), +tyThingToIfaceDecl (AnId id) + = IfaceId { ifName = getOccName id, + ifType = toIfaceType (idType id), ifIdInfo = info } where - info = case toIfaceIdInfo ext (idInfo id) of + info = case toIfaceIdInfo (idInfo id) of [] -> NoInfo items -> HasInfo items -tyThingToIfaceDecl ext (AClass clas) - = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, +tyThingToIfaceDecl (AClass clas) + = IfaceClass { ifCtxt = toIfaceContext sc_theta, ifName = getOccName clas, ifTyVars = toIfaceTvBndrs clas_tyvars, ifFDs = map toIfaceFD clas_fds, - ifATs = map (tyThingToIfaceDecl ext . ATyCon) clas_ats, + ifATs = map (tyThingToIfaceDecl . ATyCon) clas_ats, ifSigs = map toIfaceClassOp op_stuff, ifRec = boolToRecFlag (isRecursiveTyCon tycon) } where @@ -1019,7 +1066,7 @@ tyThingToIfaceDecl ext (AClass clas) toIfaceClassOp (sel_id, def_meth) = ASSERT(sel_tyvars == clas_tyvars) - IfaceClassOp (getOccName sel_id) def_meth (toIfaceType ext op_ty) + IfaceClassOp (getOccName sel_id) def_meth (toIfaceType op_ty) where -- Be careful when splitting the type, because of things -- like class Foo a where @@ -1029,19 +1076,19 @@ tyThingToIfaceDecl ext (AClass clas) (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) op_ty = funResultTy rho_ty - toIfaceFD (tvs1, tvs2) = (map (occNameFS.getOccName) tvs1, map (occNameFS.getOccName) tvs2) + toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2) -tyThingToIfaceDecl ext (ATyCon tycon) +tyThingToIfaceDecl (ATyCon tycon) | isSynTyCon tycon - = IfaceSyn { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs tyvars, + = IfaceSyn { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs tyvars, ifOpenSyn = syn_isOpen, - ifSynRhs = toIfaceType ext syn_tyki } + ifSynRhs = toIfaceType syn_tyki } | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, - ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), + ifCtxt = toIfaceContext (tyConStupidTheta tycon), ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, @@ -1088,51 +1135,52 @@ tyThingToIfaceDecl ext (ATyCon tycon) ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), ifConEqSpec = to_eq_spec (dataConEqSpec data_con), - ifConCtxt = toIfaceContext ext (dataConTheta data_con), - ifConArgTys = map (toIfaceType ext) - (dataConOrigArgTys data_con), + ifConCtxt = toIfaceContext (dataConTheta data_con), + ifConArgTys = map toIfaceType (dataConOrigArgTys data_con), ifConFields = map getOccName (dataConFieldLabels data_con), ifConStricts = dataConStrictMarks data_con } - to_eq_spec spec = [(getOccName tv, toIfaceType ext ty) | (tv,ty) <- spec] + to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec] famInstToIface Nothing = Nothing famInstToIface (Just (famTyCon, instTys)) = - Just (toIfaceTyCon ext famTyCon, map (toIfaceType ext) instTys) + Just (toIfaceTyCon famTyCon, map toIfaceType instTys) -tyThingToIfaceDecl ext (ADataCon dc) +tyThingToIfaceDecl (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier +getFS x = occNameFS (getOccName x) + -------------------------- -instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst -instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, - is_cls = cls, is_tcs = mb_tcs, - is_orph = orph }) - = IfaceInst { ifDFun = getOccName dfun_id, +instanceToIfaceInst :: Instance -> IfaceInst +instanceToIfaceInst ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, + is_cls = cls, is_tcs = mb_tcs, + is_orph = orph }) + = IfaceInst { ifDFun = getName dfun_id, ifOFlag = oflag, - ifInstCls = ext_lhs cls, + ifInstCls = cls, ifInstTys = map do_rough mb_tcs, ifInstOrph = orph } where do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) + do_rough (Just n) = Just (toIfaceTyCon_name n) -------------------------- -famInstToIfaceFamInst :: (Name -> IfaceExtName) -> FamInst -> IfaceFamInst -famInstToIfaceFamInst ext_lhs fi@(FamInst { fi_tycon = tycon, +famInstToIfaceFamInst :: FamInst -> IfaceFamInst +famInstToIfaceFamInst fi@(FamInst { fi_tycon = tycon, fi_fam = fam, fi_tcs = mb_tcs }) - = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon ext_lhs tycon - , ifFamInstFam = ext_lhs fam + = IfaceFamInst { ifFamInstTyCon = toIfaceTyCon tycon + , ifFamInstFam = fam , ifFamInstTys = map do_rough mb_tcs } where do_rough Nothing = Nothing - do_rough (Just n) = Just (toIfaceTyCon_name ext_lhs n) + do_rough (Just n) = Just (toIfaceTyCon_name n) -------------------------- -toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] -toIfaceIdInfo ext id_info +toIfaceIdInfo :: IdInfo -> [IfaceInfoItem] +toIfaceIdInfo id_info = catMaybes [arity_hsinfo, caf_hsinfo, strict_hsinfo, inline_hsinfo, wrkr_hsinfo, unfold_hsinfo] where @@ -1158,7 +1206,7 @@ toIfaceIdInfo ext id_info has_worker = case work_info of { HasWorker _ _ -> True; other -> False } wrkr_hsinfo = case work_info of HasWorker work_id wrap_arity -> - Just (HsWorker (ext (idName work_id)) wrap_arity) + Just (HsWorker ((idName work_id)) wrap_arity) NoWorker -> Nothing ------------ Unfolding -------------- @@ -1171,7 +1219,7 @@ toIfaceIdInfo ext id_info -- unconditional NOINLINE, etc. See TidyPgm.addExternal unfold_hsinfo | no_unfolding = Nothing | has_worker = Nothing -- Unfolding is implicit - | otherwise = Just (HsUnfold (toIfaceExpr ext rhs)) + | otherwise = Just (HsUnfold (toIfaceExpr rhs)) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info @@ -1182,63 +1230,61 @@ toIfaceIdInfo ext id_info | otherwise = Just (HsInline inline_prag) -------------------------- -coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names - -> (Name -> IfaceExtName) -- For the RHS names - -> CoreRule -> IfaceRule -coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn}) +coreRuleToIfaceRule :: CoreRule -> IfaceRule +coreRuleToIfaceRule (BuiltinRule { ru_fn = fn}) = pprTrace "toHsRule: builtin" (ppr fn) $ - bogusIfaceRule (mkIfaceExtName fn) + bogusIfaceRule fn -coreRuleToIfaceRule ext_lhs ext_rhs - (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, - ru_args = args, ru_rhs = rhs, ru_orph = orph }) +coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn, + ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, ru_orph = orph }) = IfaceRule { ifRuleName = name, ifActivation = act, - ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs, - ifRuleHead = ext_lhs fn, + ifRuleBndrs = map toIfaceBndr bndrs, + ifRuleHead = fn, ifRuleArgs = map do_arg args, - ifRuleRhs = toIfaceExpr ext_rhs rhs, + ifRuleRhs = toIfaceExpr rhs, ifRuleOrph = orph } where -- For type args we must remove synonyms from the outermost -- level. Reason: so that when we read it back in we'll -- construct the same ru_rough field as we have right now; -- see tcIfaceRule - do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty)) - do_arg arg = toIfaceExpr ext_lhs arg + do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) + do_arg arg = toIfaceExpr arg -bogusIfaceRule :: IfaceExtName -> IfaceRule +bogusIfaceRule :: Name -> IfaceRule bogusIfaceRule id_name = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } --------------------- -toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr -toIfaceExpr ext (Var v) = toIfaceVar ext v -toIfaceExpr ext (Lit l) = IfaceLit l -toIfaceExpr ext (Type ty) = IfaceType (toIfaceType ext ty) -toIfaceExpr ext (Lam x b) = IfaceLam (toIfaceBndr ext x) (toIfaceExpr ext b) -toIfaceExpr ext (App f a) = toIfaceApp ext f [a] -toIfaceExpr ext (Case s x ty as) = IfaceCase (toIfaceExpr ext s) (occNameFS (getOccName x)) (toIfaceType ext ty) (map (toIfaceAlt ext) as) -toIfaceExpr ext (Let b e) = IfaceLet (toIfaceBind ext b) (toIfaceExpr ext e) -toIfaceExpr ext (Cast e co) = IfaceCast (toIfaceExpr ext e) (toIfaceType ext co) -toIfaceExpr ext (Note n e) = IfaceNote (toIfaceNote ext n) (toIfaceExpr ext e) +toIfaceExpr :: CoreExpr -> IfaceExpr +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co) +toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) --------------------- -toIfaceNote ext (SCC cc) = IfaceSCC cc -toIfaceNote ext InlineMe = IfaceInlineMe -toIfaceNote ext (CoreNote s) = IfaceCoreNote s +toIfaceNote (SCC cc) = IfaceSCC cc +toIfaceNote InlineMe = IfaceInlineMe +toIfaceNote (CoreNote s) = IfaceCoreNote s --------------------- -toIfaceBind ext (NonRec b r) = IfaceNonRec (toIfaceIdBndr ext b) (toIfaceExpr ext r) -toIfaceBind ext (Rec prs) = IfaceRec [(toIfaceIdBndr ext b, toIfaceExpr ext r) | (b,r) <- prs] +toIfaceBind (NonRec b r) = IfaceNonRec (toIfaceIdBndr b) (toIfaceExpr r) +toIfaceBind (Rec prs) = IfaceRec [(toIfaceIdBndr b, toIfaceExpr r) | (b,r) <- prs] --------------------- -toIfaceAlt ext (c,bs,r) = (toIfaceCon c, map (occNameFS.getOccName) bs, toIfaceExpr ext r) +toIfaceAlt (c,bs,r) = (toIfaceCon c, map getFS bs, toIfaceExpr r) --------------------- toIfaceCon (DataAlt dc) | isTupleTyCon tc = IfaceTupleAlt (tupleTyConBoxity tc) - | otherwise = IfaceDataAlt (getOccName dc) + | otherwise = IfaceDataAlt (getName dc) where tc = dataConTyCon dc @@ -1246,8 +1292,8 @@ toIfaceCon (LitAlt l) = IfaceLitAlt l toIfaceCon DEFAULT = IfaceDefault --------------------- -toIfaceApp ext (App f a) as = toIfaceApp ext f (a:as) -toIfaceApp ext (Var v) as +toIfaceApp (App f a) as = toIfaceApp f (a:as) +toIfaceApp (Var v) as = case isDataConWorkId_maybe v of -- We convert the *worker* for tuples into IfaceTuples Just dc | isTupleTyCon tc && saturated @@ -1255,22 +1301,22 @@ toIfaceApp ext (Var v) as where val_args = dropWhile isTypeArg as saturated = val_args `lengthIs` idArity v - tup_args = map (toIfaceExpr ext) val_args + tup_args = map toIfaceExpr val_args tc = dataConTyCon dc - other -> mkIfaceApps ext (toIfaceVar ext v) as + other -> mkIfaceApps (toIfaceVar v) as -toIfaceApp ext e as = mkIfaceApps ext (toIfaceExpr ext e) as +toIfaceApp e as = mkIfaceApps (toIfaceExpr e) as -mkIfaceApps ext f as = foldl (\f a -> IfaceApp f (toIfaceExpr ext a)) f as +mkIfaceApps f as = foldl (\f a -> IfaceApp f (toIfaceExpr a)) f as --------------------- -toIfaceVar :: (Name -> IfaceExtName) -> Id -> IfaceExpr -toIfaceVar ext v - | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType ext (idType v)) +toIfaceVar :: Id -> IfaceExpr +toIfaceVar v + | Just fcall <- isFCallId_maybe v = IfaceFCall fcall (toIfaceType (idType v)) -- Foreign calls have special syntax - | isExternalName name = IfaceExt (ext name) - | otherwise = IfaceLcl (occNameFS (nameOccName name)) + | isExternalName name = IfaceExt name + | otherwise = IfaceLcl (getFS name) where name = idName v \end{code} diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index fa227e6756..c16846ec28 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -14,9 +14,9 @@ module TcIface ( import IfaceSyn import LoadIface ( loadInterface, loadWiredInHomeIface, findAndReadIface, loadDecls ) -import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, +import IfaceEnv ( lookupIfaceTop, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, + tcIfaceTyVar, tcIfaceLclId, newIfaceName, newIfaceNames, ifaceExportNames ) import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, @@ -511,10 +511,9 @@ tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, ifInstCls = cls, ifInstTys = mb_tcs, ifInstOrph = orph }) = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ - tcIfaceExtId (LocalTop dfun_occ) - ; cls' <- lookupIfaceExt cls - ; mb_tcs' <- mapM tc_rough mb_tcs - ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) } + tcIfaceExtId dfun_occ + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' orph dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, @@ -523,12 +522,8 @@ tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, -- ^^^this line doesn't work, but vvv this does => CPP in Haskell = evil! = do { tycon' <- forkM (text ("Inst tycon") <+> ppr tycon) $ tcIfaceTyCon tycon - ; fam' <- lookupIfaceExt fam - ; mb_tcs' <- mapM tc_rough mb_tcs - ; return (mkImportedFamInst fam' mb_tcs' tycon') } - -tc_rough Nothing = return Nothing -tc_rough (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') } + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedFamInst fam mb_tcs' tycon') } \end{code} @@ -554,20 +549,21 @@ tcIfaceRule :: IfaceRule -> IfL CoreRule tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, ifRuleOrph = orph }) - = do { fn' <- lookupIfaceExt fn - ; ~(bndrs', args', rhs') <- + = do { ~(bndrs', args', rhs') <- -- Typecheck the payload lazily, in the hope it'll never be looked at forkM (ptext SLIT("Rule") <+> ftext name) $ bindIfaceBndrs bndrs $ \ bndrs' -> do { args' <- mappM tcIfaceExpr args ; rhs' <- tcIfaceExpr rhs ; return (bndrs', args', rhs') } - ; mb_tcs <- mapM ifTopFreeName args - ; returnM (Rule { ru_name = name, ru_fn = fn', ru_act = act, + ; let mb_tcs = map ifTopFreeName args + ; lcl <- getLclEnv + ; let this_module = if_mod lcl + ; returnM (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs', ru_orph = orph, ru_rough = mb_tcs, - ru_local = isLocalIfaceExtName fn }) } + ru_local = nameModule fn == this_module }) } where -- This function *must* mirror exactly what Rules.topFreeName does -- We could have stored the ru_rough field in the iface file @@ -576,14 +572,11 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd -- type syononyms at the top of a type arg. Since -- we can't tell at this point, we are careful not -- to write them out in coreRuleToIfaceRule - ifTopFreeName :: IfaceExpr -> IfL (Maybe Name) - ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) - = do { n <- lookupIfaceTc tc - ; return (Just n) } - ifTopFreeName (IfaceApp f a) = ifTopFreeName f - ifTopFreeName (IfaceExt ext) = do { n <- lookupIfaceExt ext - ; return (Just n) } - ifTopFreeName other = return Nothing + ifTopFreeName :: IfaceExpr -> Maybe Name + ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) = Just (ifaceTyConName tc) + ifTopFreeName (IfaceApp f a) = ifTopFreeName f + ifTopFreeName (IfaceExt n) = Just n + ifTopFreeName other = Nothing \end{code} @@ -725,8 +718,7 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_strs, rhs) - = do { let tycon_mod = nameModule (tyConName tycon) - ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) + = do { con <- tcIfaceDataCon data_occ ; ASSERT2( con `elem` tyConDataCons tycon, ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) tcIfaceDataAlt con inst_tys arg_strs rhs } @@ -931,12 +923,11 @@ tcIfaceTyCon IfaceCharTc = tcWiredInTyCon charTyCon tcIfaceTyCon IfaceListTc = tcWiredInTyCon listTyCon tcIfaceTyCon IfacePArrTc = tcWiredInTyCon parrTyCon tcIfaceTyCon (IfaceTupTc bx ar) = tcWiredInTyCon (tupleTyCon bx ar) -tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm - ; thing <- tcIfaceGlobal name +tcIfaceTyCon (IfaceTc name) = do { thing <- tcIfaceGlobal name ; return (check_tc (tyThingTyCon thing)) } where #ifdef DEBUG - check_tc tc = case toIfaceTyCon (error "urk") tc of + check_tc tc = case toIfaceTyCon tc of IfaceTc _ -> tc other -> pprTrace "check_tc" (ppr tc) tc #else @@ -956,24 +947,21 @@ tcWiredInTyCon :: TyCon -> IfL TyCon tcWiredInTyCon tc = do { ifCheckWiredInThing (tyConName tc) ; return tc } -tcIfaceClass :: IfaceExtName -> IfL Class -tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name - ; thing <- tcIfaceGlobal name - ; return (tyThingClass thing) } +tcIfaceClass :: Name -> IfL Class +tcIfaceClass name = do { thing <- tcIfaceGlobal name + ; return (tyThingClass thing) } -tcIfaceDataCon :: IfaceExtName -> IfL DataCon -tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl - ; thing <- tcIfaceGlobal name - ; case thing of +tcIfaceDataCon :: Name -> IfL DataCon +tcIfaceDataCon name = do { thing <- tcIfaceGlobal name + ; case thing of ADataCon dc -> return dc - other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) } + other -> pprPanic "tcIfaceExtDC" (ppr name$$ ppr thing) } -tcIfaceExtId :: IfaceExtName -> IfL Id -tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl - ; thing <- tcIfaceGlobal name - ; case thing of +tcIfaceExtId :: Name -> IfL Id +tcIfaceExtId name = do { thing <- tcIfaceGlobal name + ; case thing of AnId id -> return id - other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) } + other -> pprPanic "tcIfaceExtId" (ppr name$$ ppr thing) } \end{code} %************************************************************************ @@ -1018,7 +1006,7 @@ bindIfaceIds bndrs thing_inside newExtCoreBndr :: IfaceIdBndr -> IfL Id newExtCoreBndr (var, ty) = do { mod <- getIfModule - ; name <- newGlobalBinder mod (mkVarOccFS var) Nothing noSrcLoc + ; name <- newGlobalBinder mod (mkVarOccFS var) noSrcLoc ; ty' <- tcIfaceType ty ; return (mkLocalId name ty') } diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 70039a9654..c786cbba16 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -94,7 +94,7 @@ module GHC ( -- ** Names Name, - nameModule, nameParent_maybe, pprParenSymName, nameSrcLoc, + nameModule, pprParenSymName, nameSrcLoc, NamedThing(..), RdrName(Qual,Unqual), @@ -215,8 +215,7 @@ import FunDeps ( pprFundeps ) import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon, dataConFieldLabels, dataConStrictMarks, dataConIsInfix, isVanillaDataCon ) -import Name ( Name, nameModule, NamedThing(..), nameParent_maybe, - nameSrcLoc ) +import Name ( Name, nameModule, NamedThing(..), nameSrcLoc ) import OccName ( parenSymOcc ) import NameEnv ( nameEnvElts ) import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) @@ -821,7 +820,8 @@ checkModule session@(Session ref) mod = do (Just (tc_binds, rdr_env, details))) -> do let minf = ModuleInfo { minf_type_env = md_types details, - minf_exports = md_exports details, + minf_exports = availsToNameSet $ + md_exports details, minf_rdr_env = Just rdr_env, minf_instances = md_insts details } @@ -1730,7 +1730,7 @@ getPrintUnqual s = withSession s (return . icPrintUnqual . hsc_IC) -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo { minf_type_env :: TypeEnv, - minf_exports :: NameSet, + minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod minf_instances :: [Instance] -- ToDo: this should really contain the ModIface too @@ -1785,7 +1785,7 @@ getHomeModuleInfo hsc_env mdl = let details = hm_details hmi return (Just (ModuleInfo { minf_type_env = md_types details, - minf_exports = md_exports details, + minf_exports = availsToNameSet (md_exports details), minf_rdr_env = mi_globals $! hm_iface hmi, minf_instances = md_insts details })) diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 01c27ab51b..0563f3442c 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -527,7 +527,7 @@ hscNormalIface simpl_result <- {-# SCC "MkFinalIface" #-} mkIface hsc_env maybe_old_iface simpl_result details -- Emit external core - emitExternalCore (hsc_dflags hsc_env) (mg_exports simpl_result) cg_guts -- Move this? --Lemmih 03/07/2006 + emitExternalCore (hsc_dflags hsc_env) (availsToNameSet (mg_exports simpl_result)) cg_guts -- Move this? --Lemmih 03/07/2006 dumpIfaceStats hsc_env ------------------- @@ -541,9 +541,11 @@ hscNormalIface simpl_result hscWriteIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) hscWriteIface (iface, no_change, details, a) = do mod_summary <- gets compModSummary + hsc_env <- gets compHscEnv + let dflags = hsc_dflags hsc_env liftIO $ do unless no_change - $ writeIfaceFile (ms_location mod_summary) iface + $ writeIfaceFile dflags (ms_location mod_summary) iface return (iface, details, a) hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 6bc1197f71..d3c5f7f74f 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1,5 +1,5 @@ - -% (c) The University of Glasgow, 2000 +% +% (c) The University of Glasgow, 2006 % \section[HscTypes]{Types for the per-module compiler} @@ -36,7 +36,7 @@ module HscTypes ( FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv, - implicitTyThings, + implicitTyThings, isImplicitTyThing, TyThing(..), tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, @@ -47,7 +47,7 @@ module HscTypes ( WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, NameCache(..), OrigNameCache, OrigIParamCache, - Avails, availsToNameSet, availName, availNames, + Avails, availsToNameSet, availsToNameEnv, availName, availNames, GenAvailInfo(..), AvailInfo, RdrAvailInfo, IfaceExport, @@ -81,12 +81,11 @@ import InstEnv ( InstEnv, Instance ) import FamInstEnv ( FamInstEnv, FamInst ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) -import Id ( Id ) +import Id ( Id, isImplicitId ) import Type ( TyThing(..) ) import Class ( Class, classSelIds, classATs, classTyCon ) -import TyCon ( TyCon, tyConSelIds, tyConDataCons, - newTyConCo_maybe, tyConFamilyCoercion_maybe ) +import TyCon import DataCon ( DataCon, dataConImplicitIds ) import PrelNames ( gHC_PRIM ) import Packages ( PackageId ) @@ -94,10 +93,7 @@ import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( Version, initialVersion, IPName, Fixity, defaultFixity, DeprecTxt ) - -import IfaceSyn ( IfaceInst, IfaceFamInst, IfaceRule, - IfaceDecl(ifName) ) - +import IfaceSyn import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) import Maybes ( orElse, expectJust ) @@ -430,29 +426,27 @@ data ModIface -- and are not put into the interface file mi_dep_fn :: Name -> Maybe DeprecTxt, -- Cached lookup for mi_deprecs mi_fix_fn :: OccName -> Fixity, -- Cached lookup for mi_fixities - mi_ver_fn :: OccName -> Maybe Version -- Cached lookup for mi_decls + mi_ver_fn :: OccName -> Maybe (OccName, Version) + -- Cached lookup for mi_decls -- The Nothing in mi_ver_fn means that the thing -- isn't in decls. It's useful to know that when -- seeing if we are up to date wrt the old interface + -- The 'OccName' is the parent of the name, if it has one. } -- Should be able to construct ModDetails from mi_decls in ModIface data ModDetails = ModDetails { -- The next three fields are created by the typechecker - md_exports :: NameSet, - md_types :: !TypeEnv, + md_exports :: [AvailInfo], + md_types :: !TypeEnv, md_fam_insts :: ![FamInst], -- Cached value extracted from md_types - md_insts :: ![Instance], -- Dfun-ids for the instances in this - -- module - - md_rules :: ![CoreRule] -- Domain may include Ids from other - -- modules - + md_insts :: ![Instance], -- Dfun-ids for the instances in this module + md_rules :: ![CoreRule] -- Domain may include Ids from other modules } emptyModDetails = ModDetails { md_types = emptyTypeEnv, - md_exports = emptyNameSet, + md_exports = [], md_insts = [], md_rules = [], md_fam_insts = [] } @@ -466,7 +460,7 @@ data ModGuts = ModGuts { mg_module :: !Module, mg_boot :: IsBootInterface, -- Whether it's an hs-boot module - mg_exports :: !NameSet, -- What it exports + mg_exports :: ![AvailInfo], -- What it exports mg_deps :: !Dependencies, -- What is below it, directly or -- otherwise mg_dir_imps :: ![Module], -- Directly-imported modules; used to @@ -667,6 +661,16 @@ implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++ -- For data cons add the worker and wrapper (if any) implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) +-- | returns 'True' if there should be no interface-file declaration +-- for this thing on its own: either it is built-in, or it is part +-- of some other declaration, or it is generated implicitly by some +-- other declaration. +isImplicitTyThing :: TyThing -> Bool +isImplicitTyThing (ADataCon _) = True +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (AClass _) = False +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc + -- For newtypes and indexed data types, add the implicit coercion tycon implicitCoTyCon tc = map ATyCon . catMaybes $ [newTyConCo_maybe tc, @@ -758,14 +762,19 @@ These types are defined here because they are mentioned in ModDetails, but they are mostly elaborated elsewhere \begin{code} -mkIfaceVerCache :: [(Version,IfaceDecl)] -> OccName -> Maybe Version +mkIfaceVerCache :: [(Version,IfaceDecl)] + -> (OccName -> Maybe (OccName, Version)) mkIfaceVerCache pairs = \occ -> lookupOccEnv env occ where - env = foldl add emptyOccEnv pairs - add env (v,d) = extendOccEnv env (ifName d) v + env = foldr add_decl emptyOccEnv pairs + add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d) + where + decl_name = ifName d + env1 = extendOccEnv env0 decl_name (decl_name, v) + add_imp bndr env = extendOccEnv env bndr (decl_name, v) -emptyIfaceVerCache :: OccName -> Maybe Version +emptyIfaceVerCache :: OccName -> Maybe (OccName, Version) emptyIfaceVerCache occ = Nothing ------------------ Deprecations ------------------------- @@ -824,9 +833,13 @@ data GenAvailInfo name = Avail name -- An ordinary identifier type IfaceExport = (Module, [GenAvailInfo OccName]) availsToNameSet :: [AvailInfo] -> NameSet -availsToNameSet avails = foldl add emptyNameSet avails - where - add set avail = addListToNameSet set (availNames avail) +availsToNameSet avails = foldr add emptyNameSet avails + where add avail set = addListToNameSet set (availNames avail) + +availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo +availsToNameEnv avails = foldr add emptyNameEnv avails + where add avail env = extendNameEnvList env + (zip (availNames avail) (repeat avail)) availName :: GenAvailInfo name -> name availName (Avail n) = n @@ -911,6 +924,7 @@ data Usage = Usage { usg_name :: ModuleName, -- Name of the module usg_mod :: Version, -- Module version usg_entities :: [(OccName,Version)], -- Sorted by occurrence name + -- NB. usages are for parent names only, eg. tycon but not constructors. usg_exports :: Maybe Version, -- Export-list version, if we depend on it usg_rules :: Version -- Orphan-rules version (for non-orphan -- modules this will always be initialVersion) diff --git a/compiler/main/Main.hs b/compiler/main/Main.hs index 0dd1cbee56..55234e7636 100644 --- a/compiler/main/Main.hs +++ b/compiler/main/Main.hs @@ -19,6 +19,7 @@ import CmdLineParser -- Implementations of the various modes (--show-iface, mkdependHS. etc.) import LoadIface ( showIface ) +import HscMain ( newHscEnv ) import DriverPipeline ( oneShot, compileFile ) import DriverMkDepend ( doMkDependHS ) #ifdef GHCI @@ -147,7 +148,7 @@ main = PrintLibdir -> putStrLn (topDir dflags) ShowVersion -> showVersion ShowNumVersion -> putStrLn cProjectVersion - ShowInterface f -> showIface f + ShowInterface f -> doShowIface dflags f DoMake -> doMake session srcs DoMkDependHS -> doMkDependHS session (map fst srcs) StopBefore p -> oneShot dflags p srcs @@ -395,6 +396,15 @@ doMake sess srcs = do when (failed ok_flag) (exitWith (ExitFailure 1)) return () + +-- --------------------------------------------------------------------------- +-- --show-iface mode + +doShowIface :: DynFlags -> FilePath -> IO () +doShowIface dflags file = do + hsc_env <- newHscEnv dflags + showIface hsc_env file + -- --------------------------------------------------------------------------- -- Various banners and verbosity output. diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index b04830b168..dc0ea7e1b8 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -28,7 +28,7 @@ import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( Arity, isNeverActive, isNonRuleLoopBreaker ) import Name ( Name, getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc, nameParent_maybe, + localiseName, isExternalName, nameSrcLoc, isWiredInName, getName ) import NameSet ( NameSet, elemNameSet ) @@ -43,12 +43,7 @@ import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, isEnumerationTyCon, isOpenTyCon ) import Class ( classSelIds ) import Module ( Module ) -import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), - TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, - extendTypeEnvWithIds, lookupTypeEnv, - ModGuts(..), TyThing(..), ModDetails(..), - Dependencies(..) - ) +import HscTypes import Maybes ( orElse, mapCatMaybes ) import ErrUtils ( showPass, dumpIfSet_core ) import PackageConfig ( PackageId ) @@ -264,7 +259,8 @@ tidyProgram hsc_env ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds - ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env + ; let { export_set = availsToNameSet exports + ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env tidy_binds ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts -- A DFunId will have a binding in tidy_binds, and so @@ -664,7 +660,6 @@ tidyTopName mod nc_var ext_ids occ_env id global = isExternalName name local = not global internal = not external - mb_parent = nameParent_maybe name loc = nameSrcLoc name (occ_env', occ') = tidyOccName occ_env (nameOccName name) @@ -674,7 +669,7 @@ tidyTopName mod nc_var ext_ids occ_env id (us1, us2) = splitUniqSupply (nsUniqs nc) uniq = uniqFromSupply us1 - mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc + mk_new_external nc = allocateGlobalBinder nc mod occ' loc -- If we want to externalise a currently-local name, check -- whether we have already assigned a unique for it. -- If so, use it; if not, extend the table. diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index dd3d8b7543..b37add305e 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -11,7 +11,7 @@ import Type ( Kind, liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, argTypeKindTyCon, ubxTupleKindTyCon, mkArrowKind, mkTyConApp ) -import Name( nameOccName, nameModule ) +import Name( Name, nameOccName, nameModule ) import Module import PackageConfig ( mainPackageId ) import ParserCoreUtils @@ -225,7 +225,7 @@ kind :: { IfaceKind } aexp :: { IfaceExpr } : var_occ { IfaceLcl $1 } - | modid '.' qd_occ { IfaceExt (ExtPkg $1 (mkVarOccFS $3)) } + | modid '.' qd_occ { IfaceExt undefined {-ToDo!!! (ExtPkg $1 (mkVarOccFS $3))-} } | lit { IfaceLit $1 } | '(' exp ')' { $2 } @@ -258,7 +258,7 @@ alts1 :: { [IfaceAlt] } alt :: { IfaceAlt } : modid '.' d_pat_occ bndrs '->' exp - { (IfaceDataAlt $3, map ifaceBndrName $4, $6) } + { (IfaceDataAlt undefined {-ToDo!!! $3 -}, map ifaceBndrName $4, $6) } -- The external syntax currently includes the types of the -- the args, but they aren't needed internally -- Nor is the module qualifier @@ -281,8 +281,8 @@ var_occ :: { FastString } -- Type constructor -q_tc_name :: { IfaceExtName } - : modid '.' CNAME { ExtPkg $1 (mkOccName tcName $3) } +q_tc_name :: { Name } + : modid '.' CNAME { undefined {-ToDo!!! ExtPkg $1 (mkOccName tcName $3)-} } -- Data constructor in a pattern or data type declaration; use the dataName, -- because that's what we expect in Core case patterns @@ -318,10 +318,7 @@ convRatLit i aty = pprPanic "Unknown rational literal type" (ppr aty) eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh! -eqTc (IfaceTc (ExtPkg mod occ)) tycon - = mod == nameModule nm && occ == nameOccName nm - where - nm = tyConName tycon +eqTc (IfaceTc name) tycon = name == tyConName tycon -- Tiresomely, we have to generate both HsTypes (in type/class decls) -- and IfaceTypes (in Core expressions). So we parse them as IfaceTypes, @@ -361,8 +358,8 @@ ifaceArrow ifT1 ifT2 = IfaceFunTy ifT1 ifT2 toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual (mkTyVarOcc tv)) (toKind k) -ifaceExtRdrName :: IfaceExtName -> RdrName -ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ +ifaceExtRdrName :: Name -> RdrName +ifaceExtRdrName name = mkOrig (nameModule name) (nameOccName name) ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) add_forall tv (L _ (HsForAllTy exp tvs cxt t)) diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index 36413dd18a..bccf84fa1d 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -446,9 +446,9 @@ runMainIOName = varQual gHC_TOP_HANDLER FSLIT("runMainIO") runMainKey orderingTyConName = tcQual gHC_BASE FSLIT("Ordering") orderingTyConKey -eitherTyConName = tcQual dATA_EITHER FSLIT("Either") eitherTyConKey -leftDataConName = conName eitherTyConName FSLIT("Left") leftDataConKey -rightDataConName = conName eitherTyConName FSLIT("Right") rightDataConKey +eitherTyConName = tcQual dATA_EITHER FSLIT("Either") eitherTyConKey +leftDataConName = conName dATA_EITHER FSLIT("Left") leftDataConKey +rightDataConName = conName dATA_EITHER FSLIT("Right") rightDataConKey -- Generics crossTyConName = tcQual gHC_BASE FSLIT(":*:") crossTyConKey @@ -466,18 +466,18 @@ eqStringName = varQual gHC_BASE FSLIT("eqString") eqStringIdKey inlineIdName = varQual gHC_BASE FSLIT("inline") inlineIdKey -- Base classes (Eq, Ord, Functor) -eqClassName = clsQual gHC_BASE FSLIT("Eq") eqClassKey -eqName = methName eqClassName FSLIT("==") eqClassOpKey -ordClassName = clsQual gHC_BASE FSLIT("Ord") ordClassKey -geName = methName ordClassName FSLIT(">=") geClassOpKey -functorClassName = clsQual gHC_BASE FSLIT("Functor") functorClassKey +eqClassName = clsQual gHC_BASE FSLIT("Eq") eqClassKey +eqName = methName gHC_BASE FSLIT("==") eqClassOpKey +ordClassName = clsQual gHC_BASE FSLIT("Ord") ordClassKey +geName = methName gHC_BASE FSLIT(">=") geClassOpKey +functorClassName = clsQual gHC_BASE FSLIT("Functor") functorClassKey -- Class Monad -monadClassName = clsQual gHC_BASE FSLIT("Monad") monadClassKey -thenMName = methName monadClassName FSLIT(">>") thenMClassOpKey -bindMName = methName monadClassName FSLIT(">>=") bindMClassOpKey -returnMName = methName monadClassName FSLIT("return") returnMClassOpKey -failMName = methName monadClassName FSLIT("fail") failMClassOpKey +monadClassName = clsQual gHC_BASE FSLIT("Monad") monadClassKey +thenMName = methName gHC_BASE FSLIT(">>") thenMClassOpKey +bindMName = methName gHC_BASE FSLIT(">>=") bindMClassOpKey +returnMName = methName gHC_BASE FSLIT("return") returnMClassOpKey +failMName = methName gHC_BASE FSLIT("fail") failMClassOpKey -- Random PrelBase functions otherwiseIdName = varQual gHC_BASE FSLIT("otherwise") otherwiseIdKey @@ -506,25 +506,25 @@ fstName = varQual dATA_TUP FSLIT("fst") fstIdKey sndName = varQual dATA_TUP FSLIT("snd") sndIdKey -- Module PrelNum -numClassName = clsQual gHC_NUM FSLIT("Num") numClassKey -fromIntegerName = methName numClassName FSLIT("fromInteger") fromIntegerClassOpKey -minusName = methName numClassName FSLIT("-") minusClassOpKey -negateName = methName numClassName FSLIT("negate") negateClassOpKey -plusIntegerName = varQual gHC_NUM FSLIT("plusInteger") plusIntegerIdKey -timesIntegerName = varQual gHC_NUM FSLIT("timesInteger") timesIntegerIdKey -integerTyConName = tcQual gHC_NUM FSLIT("Integer") integerTyConKey -smallIntegerDataConName = conName integerTyConName FSLIT("S#") smallIntegerDataConKey -largeIntegerDataConName = conName integerTyConName FSLIT("J#") largeIntegerDataConKey +numClassName = clsQual gHC_NUM FSLIT("Num") numClassKey +fromIntegerName = methName gHC_NUM FSLIT("fromInteger") fromIntegerClassOpKey +minusName = methName gHC_NUM FSLIT("-") minusClassOpKey +negateName = methName gHC_NUM FSLIT("negate") negateClassOpKey +plusIntegerName = varQual gHC_NUM FSLIT("plusInteger") plusIntegerIdKey +timesIntegerName = varQual gHC_NUM FSLIT("timesInteger") timesIntegerIdKey +integerTyConName = tcQual gHC_NUM FSLIT("Integer") integerTyConKey +smallIntegerDataConName = conName gHC_NUM FSLIT("S#") smallIntegerDataConKey +largeIntegerDataConName = conName gHC_NUM FSLIT("J#") largeIntegerDataConKey -- PrelReal types and classes -rationalTyConName = tcQual gHC_REAL FSLIT("Rational") rationalTyConKey -ratioTyConName = tcQual gHC_REAL FSLIT("Ratio") ratioTyConKey -ratioDataConName = conName ratioTyConName FSLIT(":%") ratioDataConKey -realClassName = clsQual gHC_REAL FSLIT("Real") realClassKey -integralClassName = clsQual gHC_REAL FSLIT("Integral") integralClassKey -realFracClassName = clsQual gHC_REAL FSLIT("RealFrac") realFracClassKey -fractionalClassName = clsQual gHC_REAL FSLIT("Fractional") fractionalClassKey -fromRationalName = methName fractionalClassName FSLIT("fromRational") fromRationalClassOpKey +rationalTyConName = tcQual gHC_REAL FSLIT("Rational") rationalTyConKey +ratioTyConName = tcQual gHC_REAL FSLIT("Ratio") ratioTyConKey +ratioDataConName = conName gHC_REAL FSLIT(":%") ratioDataConKey +realClassName = clsQual gHC_REAL FSLIT("Real") realClassKey +integralClassName = clsQual gHC_REAL FSLIT("Integral") integralClassKey +realFracClassName = clsQual gHC_REAL FSLIT("RealFrac") realFracClassKey +fractionalClassName = clsQual gHC_REAL FSLIT("Fractional") fractionalClassKey +fromRationalName = methName gHC_REAL FSLIT("fromRational") fromRationalClassOpKey -- PrelFloat classes floatingClassName = clsQual gHC_FLOAT FSLIT("Floating") floatingClassKey @@ -555,10 +555,10 @@ assertErrorName = varQual gHC_ERR FSLIT("assertError") assertErrorIdKey -- Enum module (Enum, Bounded) enumClassName = clsQual gHC_ENUM FSLIT("Enum") enumClassKey -enumFromName = methName enumClassName FSLIT("enumFrom") enumFromClassOpKey -enumFromToName = methName enumClassName FSLIT("enumFromTo") enumFromToClassOpKey -enumFromThenName = methName enumClassName FSLIT("enumFromThen") enumFromThenClassOpKey -enumFromThenToName = methName enumClassName FSLIT("enumFromThenTo") enumFromThenToClassOpKey +enumFromName = methName gHC_ENUM FSLIT("enumFrom") enumFromClassOpKey +enumFromToName = methName gHC_ENUM FSLIT("enumFromTo") enumFromToClassOpKey +enumFromThenName = methName gHC_ENUM FSLIT("enumFromThen") enumFromThenClassOpKey +enumFromThenToName = methName gHC_ENUM FSLIT("enumFromThenTo") enumFromThenToClassOpKey boundedClassName = clsQual gHC_ENUM FSLIT("Bounded") boundedClassKey -- List functions @@ -590,7 +590,7 @@ indexOfPName = varQual gHC_PARR FSLIT("indexOfP") indexOfPIdKey -- IOBase things ioTyConName = tcQual gHC_IO_BASE FSLIT("IO") ioTyConKey -ioDataConName = conName ioTyConName FSLIT("IO") ioDataConKey +ioDataConName = conName gHC_IO_BASE FSLIT("IO") ioDataConKey thenIOName = varQual gHC_IO_BASE FSLIT("thenIO") thenIOIdKey bindIOName = varQual gHC_IO_BASE FSLIT("bindIO") bindIOIdKey returnIOName = varQual gHC_IO_BASE FSLIT("returnIO") returnIOIdKey @@ -611,7 +611,7 @@ word16TyConName = tcQual gHC_WORD FSLIT("Word16") word16TyConKey word32TyConName = tcQual gHC_WORD FSLIT("Word32") word32TyConKey word64TyConName = tcQual gHC_WORD FSLIT("Word64") word64TyConKey wordTyConName = tcQual gHC_WORD FSLIT("Word") wordTyConKey -wordDataConName = conName wordTyConName FSLIT("W#") wordDataConKey +wordDataConName = conName gHC_WORD FSLIT("W#") wordDataConKey -- PrelPtr module ptrTyConName = tcQual gHC_PTR FSLIT("Ptr") ptrTyConKey @@ -626,7 +626,7 @@ runSTRepName = varQual gHC_ST FSLIT("runSTRep") runSTRepIdKey -- Recursive-do notation monadFixClassName = clsQual mONAD_FIX FSLIT("MonadFix") monadFixClassKey -mfixName = methName monadFixClassName FSLIT("mfix") mfixIdKey +mfixName = methName mONAD_FIX FSLIT("mfix") mfixIdKey -- Arrow notation arrAName = varQual aRROW FSLIT("arr") arrAIdKey @@ -666,20 +666,15 @@ tcQual = mk_known_key_name tcName clsQual = mk_known_key_name clsName mk_known_key_name space mod str uniq - = mkExternalName uniq mod (mkOccNameFS space str) - Nothing noSrcLoc - -conName :: Name -> FastString -> Unique -> Name --- Be careful to ghve constructor names the right parent! -conName tycon occ uniq - = mkExternalName uniq (nameModule tycon) (mkOccNameFS dataName occ) - (Just tycon) noSrcLoc - -methName :: Name -> FastString -> Unique -> Name --- Be careful to ghve method names the right parent! -methName cls occ uniq - = mkExternalName uniq (nameModule cls) (mkVarOccFS occ) - (Just cls) noSrcLoc + = mkExternalName uniq mod (mkOccNameFS space str) noSrcLoc + +conName :: Module -> FastString -> Unique -> Name +conName mod occ uniq + = mkExternalName uniq mod (mkOccNameFS dataName occ) noSrcLoc + +methName :: Module -> FastString -> Unique -> Name +methName mod occ uniq + = mkExternalName uniq mod (mkVarOccFS occ) noSrcLoc \end{code} %************************************************************************ diff --git a/compiler/prelude/TysPrim.lhs b/compiler/prelude/TysPrim.lhs index 4b6832a856..7a316835ea 100644 --- a/compiler/prelude/TysPrim.lhs +++ b/compiler/prelude/TysPrim.lhs @@ -103,7 +103,6 @@ mkPrimTc :: FastString -> Unique -> TyCon -> Name mkPrimTc fs uniq tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName fs) uniq - Nothing -- No parent object (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index 598fa42032..436b121adc 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -133,36 +133,34 @@ wiredInTyCons = [ unitTyCon -- Not treated like other tuples, because mkWiredInTyConName :: BuiltInSyntax -> Module -> FastString -> Unique -> TyCon -> Name mkWiredInTyConName built_in mod fs uniq tycon = mkWiredInName mod (mkOccNameFS tcName fs) uniq - Nothing -- No parent object (ATyCon tycon) -- Relevant TyCon built_in -mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name -> Name -mkWiredInDataConName built_in mod fs uniq datacon parent +mkWiredInDataConName :: BuiltInSyntax -> Module -> FastString -> Unique -> DataCon -> Name +mkWiredInDataConName built_in mod fs uniq datacon = mkWiredInName mod (mkOccNameFS dataName fs) uniq - (Just parent) -- Name of parent TyCon (ADataCon datacon) -- Relevant DataCon built_in charTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Char") charTyConKey charTyCon -charDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("C#") charDataConKey charDataCon charTyConName +charDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("C#") charDataConKey charDataCon intTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Int") intTyConKey intTyCon -intDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("I#") intDataConKey intDataCon intTyConName +intDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("I#") intDataConKey intDataCon boolTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Bool") boolTyConKey boolTyCon -falseDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("False") falseDataConKey falseDataCon boolTyConName -trueDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("True") trueDataConKey trueDataCon boolTyConName +falseDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("False") falseDataConKey falseDataCon +trueDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("True") trueDataConKey trueDataCon listTyConName = mkWiredInTyConName BuiltInSyntax gHC_BASE FSLIT("[]") listTyConKey listTyCon -nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_BASE FSLIT("[]") nilDataConKey nilDataCon listTyConName -consDataConName = mkWiredInDataConName BuiltInSyntax gHC_BASE FSLIT(":") consDataConKey consDataCon listTyConName +nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_BASE FSLIT("[]") nilDataConKey nilDataCon +consDataConName = mkWiredInDataConName BuiltInSyntax gHC_BASE FSLIT(":") consDataConKey consDataCon floatTyConName = mkWiredInTyConName UserSyntax gHC_FLOAT FSLIT("Float") floatTyConKey floatTyCon -floatDataConName = mkWiredInDataConName UserSyntax gHC_FLOAT FSLIT("F#") floatDataConKey floatDataCon floatTyConName +floatDataConName = mkWiredInDataConName UserSyntax gHC_FLOAT FSLIT("F#") floatDataConKey floatDataCon doubleTyConName = mkWiredInTyConName UserSyntax gHC_FLOAT FSLIT("Double") doubleTyConKey doubleTyCon -doubleDataConName = mkWiredInDataConName UserSyntax gHC_FLOAT FSLIT("D#") doubleDataConKey doubleDataCon doubleTyConName +doubleDataConName = mkWiredInDataConName UserSyntax gHC_FLOAT FSLIT("D#") doubleDataConKey doubleDataCon parrTyConName = mkWiredInTyConName BuiltInSyntax gHC_PARR FSLIT("[::]") parrTyConKey parrTyCon -parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR FSLIT("PArr") parrDataConKey parrDataCon parrTyConName +parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR FSLIT("PArr") parrDataConKey parrDataCon boolTyCon_RDR = nameRdrName boolTyConName false_RDR = nameRdrName falseDataConName @@ -240,7 +238,6 @@ pcDataConWithFixity declared_infix dc_name tyvars arg_tys tycon wrk_occ = mkDataConWorkerOcc (nameOccName dc_name) wrk_key = incrUnique (nameUnique dc_name) wrk_name = mkWiredInName mod wrk_occ wrk_key - (Just (tyConName tycon)) (AnId (dataConWorkId data_con)) UserSyntax bogus_wrap_name = pprPanic "Wired-in data wrapper id" (ppr dc_name) -- Wired-in types are too simple to need wrappers @@ -274,7 +271,7 @@ mk_tuple boxity arity = (tycon, tuple_con) tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info mod = mkTupleModule boxity arity tc_name = mkWiredInName mod (mkTupleOcc tcName boxity arity) tc_uniq - Nothing (ATyCon tycon) BuiltInSyntax + (ATyCon tycon) BuiltInSyntax tc_kind = mkArrowKinds (map tyVarKind tyvars) res_kind res_kind | isBoxed boxity = liftedTypeKind | otherwise = ubxTupleKind @@ -285,7 +282,7 @@ mk_tuple boxity arity = (tycon, tuple_con) tuple_con = pcDataCon dc_name tyvars tyvar_tys tycon tyvar_tys = mkTyVarTys tyvars dc_name = mkWiredInName mod (mkTupleOcc dataName boxity arity) dc_uniq - (Just tc_name) (ADataCon tuple_con) BuiltInSyntax + (ADataCon tuple_con) BuiltInSyntax tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity gen_info = True -- Tuples all have generics.. @@ -569,7 +566,7 @@ mkPArrFakeCon arity = data_con tyvarTys = replicate arity $ mkTyVarTy tyvar nameStr = mkFastString ("MkPArr" ++ show arity) name = mkWiredInName gHC_PARR (mkOccNameFS dataName nameStr) uniq - Nothing (ADataCon data_con) UserSyntax + (ADataCon data_con) UserSyntax uniq = mkPArrDataConUnique arity -- checks whether a data constructor is a fake constructor for parallel arrays diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 29a87918f8..74c9646573 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-2006 % \section[RnEnv]{Environment manipulation for the renamer monad} @@ -47,11 +47,13 @@ import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, Provenance(..), pprNameProvenance, importSpecLoc, importSpecModule ) -import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) +import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity, + AvailInfo, GenAvailInfo(..) ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, - nameSrcLoc, nameOccName, nameModule, nameParent, isExternalName ) + nameSrcLoc, nameOccName, nameModule, isExternalName ) import NameSet +import NameEnv ( NameEnv, lookupNameEnv ) import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, reportIfUnused ) import Module ( Module, ModuleName ) @@ -75,8 +77,8 @@ import DynFlags %********************************************************* \begin{code} -newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name -newTopSrcBinder this_mod mb_parent (L loc rdr_name) +newTopSrcBinder :: Module -> Located RdrName -> RnM Name +newTopSrcBinder this_mod (L loc rdr_name) | Just name <- isExact_maybe rdr_name = -- This is here to catch -- (a) Exact-name binders created by Template Haskell @@ -113,7 +115,7 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) -- the RdrName, not from the environment. In principle, it'd be fine to -- have an arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - ; newGlobalBinder rdr_mod rdr_occ mb_parent (srcSpanStart loc) } + ; newGlobalBinder rdr_mod rdr_occ (srcSpanStart loc) } --TODO, should pass the whole span | otherwise @@ -121,7 +123,7 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) (addErrAt loc (badQualBndrErr rdr_name)) -- Binders should not be qualified; if they are, and with a different -- module name, we we get a confusing "M.T is not in scope" error later - ; newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) } + ; newGlobalBinder this_mod (rdrNameOcc rdr_name) (srcSpanStart loc) } \end{code} %********************************************************* @@ -173,7 +175,7 @@ lookupTopBndrRn rdr_name -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name = do { loc <- getSrcSpanM - ; newGlobalBinder rdr_mod rdr_occ Nothing (srcSpanStart loc) } + ; newGlobalBinder rdr_mod rdr_occ (srcSpanStart loc) } | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name @@ -199,10 +201,18 @@ lookupLocatedSigOccRn = lookupLocatedBndrRn -- disambiguate. lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) -lookupLocatedInstDeclBndr cls = wrapLocM (lookupInstDeclBndr cls) - -lookupInstDeclBndr :: Name -> RdrName -> RnM Name -lookupInstDeclBndr cls_name rdr_name +lookupLocatedInstDeclBndr cls rdr = do + imp_avails <- getImports + wrapLocM (lookupInstDeclBndr (imp_parent imp_avails) cls) rdr + +lookupInstDeclBndr :: NameEnv AvailInfo -> Name -> RdrName -> RnM Name +-- This is called on the method name on the left-hand side of an +-- instance declaration binding. eg. instance Functor T where +-- fmap = ... +-- ^^^^ called on this +-- Regardless of how many unqualified fmaps are in scope, we want +-- the one that comes from the Functor class. +lookupInstDeclBndr availenv cls_name rdr_name | isUnqual rdr_name -- Find all the things the rdr-name maps to = do { -- and pick the one with the right parent name let { is_op gre = cls_name == nameParent (gre_name gre) @@ -220,6 +230,12 @@ lookupInstDeclBndr cls_name rdr_name -- NB: qualified names are rejected by the parser lookupImportedName rdr_name + where nameParent nm + | Just (AvailTC tc subs) <- lookupNameEnv availenv nm = tc + | otherwise = nm -- might be an Avail, if the Name is + -- in scope some other way + + newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) @@ -243,7 +259,7 @@ lookupFamInstDeclBndr mod lrdr_name@(L _ rdr_name) lookupGreRn rdr_name `thenM` \ mb_gre -> case mb_gre of { Just gre -> returnM (gre_name gre) ; - Nothing -> newTopSrcBinder mod Nothing lrdr_name } + Nothing -> newTopSrcBinder mod lrdr_name } -------------------------------------------------- -- Occurrences diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 2df8e950e6..261969b399 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -23,6 +23,8 @@ import HsSyn import RnHsSyn import TcRnMonad import RnEnv +import HscTypes ( availNames ) +import OccName ( plusOccEnv ) import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) import RnTypes ( rnHsTypeFVs, rnLPat, rnOverLit, rnPatsAndThen, rnLit, mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, @@ -573,7 +575,8 @@ rnBracket (DecBr group) -- confuse the Names for the current module. -- By using a pretend module, thFAKE, we keep them safely out of the way. - ; names <- getLocalDeclBinders gbl_env1 group + ; avails <- getLocalDeclBinders gbl_env1 group + ; let names = concatMap availNames avails ; let new_occs = map nameOccName names trimmed_rdr_env = hideSomeUnquals (tcg_rdr_env gbl_env) new_occs diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 4bca4fcaf4..e1445c7f9c 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -5,8 +5,8 @@ \begin{code} module RnNames ( - rnImports, mkRdrEnvAndImports, importsFromLocalDecls, - rnExports, mkExportNameSet, + rnImports, importsFromLocalDecls, + rnExports, getLocalDeclBinders, extendRdrEnvRn, reportUnusedNames, reportDeprecations ) where @@ -25,21 +25,19 @@ import IfaceEnv ( ifaceExportNames ) import LoadIface ( loadSrcInterface ) import TcRnMonad hiding (LIE) -import FiniteMap import PrelNames import Module -import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName, - nameParent, nameParent_maybe, isExternalName, - isBuiltInSyntax, isTyConName ) +import Name import NameSet import NameEnv import OccName ( srcDataName, isTcOcc, pprNonVarNameSpace, occNameSpace, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv ) -import HscTypes ( GenAvailInfo(..), AvailInfo, +import HscTypes ( GenAvailInfo(..), AvailInfo, availNames, availName, HomePackageTable, PackageIfaceTable, - mkPrintUnqualified, + mkPrintUnqualified, availsToNameSet, + availsToNameEnv, Deprecs(..), ModIface(..), Dependencies(..), lookupIfaceByModule, ExternalPackageState(..) ) @@ -51,13 +49,15 @@ import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, importSpecLoc, importSpecModule, isLocalGRE, pprNameProvenance ) import Outputable import UniqFM -import Maybes ( isNothing, catMaybes, mapCatMaybes, seqMaybe, orElse ) -import SrcLoc ( Located(..), mkGeneralSrcSpan, +import Maybes +import SrcLoc ( Located(..), mkGeneralSrcSpan, getLoc, unLoc, noLoc, srcLocSpan, SrcSpan ) +import FiniteMap +import ErrUtils import BasicTypes ( DeprecTxt ) import DriverPhases ( isHsBoot ) import Util ( notNull ) -import List ( partition ) +import Data.List ( nub, partition, concatMap ) import IO ( openFile, IOMode(..) ) import Monad ( when ) \end{code} @@ -71,7 +71,9 @@ import Monad ( when ) %************************************************************************ \begin{code} -rnImports :: [LImportDecl RdrName] -> RnM [LImportDecl Name] +rnImports :: [LImportDecl RdrName] + -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails) + rnImports imports -- PROCESS IMPORT DECLS -- Do the non {- SOURCE -} ones first, so that we get a helpful @@ -81,11 +83,20 @@ rnImports imports let all_imports = mk_prel_imports this_mod implicit_prelude ++ imports (source, ordinary) = partition is_source_import all_imports is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot - get_imports = rnImportDecl this_mod - stuff1 <- mapM get_imports ordinary - stuff2 <- mapM get_imports source - return (stuff1 ++ stuff2) + stuff1 <- mapM (rnImportDecl this_mod) ordinary + stuff2 <- mapM (rnImportDecl this_mod) source + let (decls, rdr_env, avails, imp_avails) = combine (stuff1 ++ stuff2) + return (decls, rdr_env, + imp_avails{ imp_parent = availsToNameEnv (nubAvails avails) }) + -- why wait until now to set the imp_parent, rather than + -- setting it in rnImportDecl for each import, and + -- combining them with plusImportAvails? The reason is + -- that we need to combine all the AvailInfos *before* + -- we build the NameEnv, otherwise the NameEnv can + -- end up with inconsistencies, eg. the parent can say + -- C(m1,m2), but the entry for m2 might only say C(m2). + -- The test mod118 illustrates the bug. where -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); -- because the former doesn't even look at Prelude.hi for instance @@ -100,6 +111,16 @@ rnImports imports = notNull [ () | L _ (ImportDecl mod _ _ _ _) <- imports, unLoc mod == pRELUDE_NAME ] + combine :: [(LImportDecl Name, GlobalRdrEnv, [AvailInfo], ImportAvails)] + -> ([LImportDecl Name], GlobalRdrEnv, [AvailInfo], ImportAvails) + combine = foldr plus ([], emptyGlobalRdrEnv, [], emptyImportAvails) + where plus (decl, gbl_env1, avails1, imp_avails1) + (decls, gbl_env2, avails2, imp_avails2) + = (decl:decls, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + avails1 ++ avails2, + imp_avails1 `plusImportAvails` imp_avails2) + preludeImportDecl :: LImportDecl RdrName preludeImportDecl = L loc $ @@ -111,125 +132,35 @@ preludeImportDecl where loc = mkGeneralSrcSpan FSLIT("Implicit import declaration") -mkRdrEnvAndImports :: [LImportDecl Name] -> RnM (GlobalRdrEnv, ImportAvails) -mkRdrEnvAndImports imports - = do this_mod <- getModule - let get_imports = importsFromImportDecl this_mod - stuff <- mapM get_imports imports - let (imp_gbl_envs, imp_avails) = unzip stuff - gbl_env :: GlobalRdrEnv - gbl_env = foldr plusGlobalRdrEnv emptyGlobalRdrEnv imp_gbl_envs - - all_avails :: ImportAvails - all_avails = foldr plusImportAvails emptyImportAvails imp_avails - -- ALL DONE - return (gbl_env, all_avails) - -\end{code} -\begin{code} -rnImportDecl :: Module - -> LImportDecl RdrName - -> RnM (LImportDecl Name) -rnImportDecl this_mod (L loc importDecl@(ImportDecl loc_imp_mod_name want_boot qual_only as_mod imp_details)) - = setSrcSpan loc $ - do iface <- loadSrcInterface doc imp_mod_name want_boot - let qual_mod_name = case as_mod of - Nothing -> imp_mod_name - Just another_name -> another_name - imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, - is_dloc = loc, is_as = qual_mod_name } - total_avails <- ifaceExportNames (mi_exports iface) - importDecl' <- rnImportDecl' iface imp_spec importDecl total_avails - return (L loc importDecl') - where imp_mod_name = unLoc loc_imp_mod_name - doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") - -rnImportDecl' :: ModIface -> ImpDeclSpec -> ImportDecl RdrName -> NameSet -> RnM (ImportDecl Name) -rnImportDecl' iface decl_spec (ImportDecl mod_name want_boot qual_only as_mod Nothing) all_names - = return $ ImportDecl mod_name want_boot qual_only as_mod Nothing -rnImportDecl' iface decl_spec (ImportDecl mod_name want_boot qual_only as_mod (Just (want_hiding,import_items))) all_names - = do import_items_mbs <- mapM (srcSpanWrapper) import_items - let rn_import_items = concat . catMaybes $ import_items_mbs - return $ ImportDecl mod_name want_boot qual_only as_mod (Just (want_hiding,rn_import_items)) - where - srcSpanWrapper (L span ieRdr) - = case get_item ieRdr of - Nothing - -> do addErrAt span (badImportItemErr iface decl_spec ieRdr) - return Nothing - Just ieNames - -> return (Just [L span ie | ie <- ieNames]) - occ_env :: OccEnv Name -- Maps OccName to corresponding Name - occ_env = mkOccEnv [(nameOccName n, n) | n <- nameSetToList all_names] - -- This env will have entries for data constructors too, - -- they won't make any difference because naked entities like T - -- in an import list map to TcOccs, not VarOccs. - sub_env :: NameEnv [Name] - sub_env = mkSubNameEnv all_names - - get_item :: IE RdrName -> Maybe [IE Name] - -- Empty result for a bad item. - -- Singleton result is typical case. - -- Can have two when we are hiding, and mention C which might be - -- both a class and a data constructor. - get_item item@(IEModuleContents _) - = Nothing - get_item (IEThingAll tc) - = do name <- check_name tc - return [IEThingAll name] - get_item (IEThingAbs tc) - | want_hiding -- hiding ( C ) - -- Here the 'C' can be a data constructor - -- *or* a type/class, or even both - = case catMaybes [check_name tc, check_name (setRdrNameSpace tc srcDataName)] of - [] -> Nothing - names -> return [ IEThingAbs n | n <- names ] - | otherwise - = do name <- check_name tc - return [IEThingAbs name] - get_item (IEThingWith n ns) -- import (C (A,B)) - = do name <- check_name n - let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name] - mb_names = map (lookupOccEnv env . rdrNameOcc) ns - names <- sequence mb_names - return [IEThingWith name names] - get_item (IEVar n) - = do name <- check_name n - return [IEVar name] - - check_name :: RdrName -> Maybe Name - check_name rdrName - = lookupOccEnv occ_env (rdrNameOcc rdrName) - - -importsFromImportDecl :: Module - -> LImportDecl Name - -> RnM (GlobalRdrEnv, ImportAvails) - -importsFromImportDecl this_mod - (L loc (ImportDecl loc_imp_mod_name want_boot qual_only as_mod imp_details)) +rnImportDecl :: Module + -> LImportDecl RdrName + -> RnM (LImportDecl Name, GlobalRdrEnv, + [AvailInfo], ImportAvails) + +rnImportDecl this_mod (L loc (ImportDecl loc_imp_mod_name want_boot + qual_only as_mod imp_details)) = - setSrcSpan loc $ + setSrcSpan loc $ do -- If there's an error in loadInterface, (e.g. interface -- file not found) we get lots of spurious errors from 'filterImports' let imp_mod_name = unLoc loc_imp_mod_name doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") - in - loadSrcInterface doc imp_mod_name want_boot `thenM` \ iface -> + + iface <- loadSrcInterface doc imp_mod_name want_boot -- Compiler sanity check: if the import didn't say -- {-# SOURCE #-} we should not get a hi-boot file - WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) + WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) $ do -- Issue a user warning for a redundant {- SOURCE -} import -- NB that we arrange to read all the ordinary imports before -- any of the {- SOURCE -} imports warnIf (want_boot && not (mi_boot iface)) - (warnRedundantSourceImport imp_mod_name) `thenM_` + (warnRedundantSourceImport imp_mod_name) let imp_mod = mi_module iface @@ -239,12 +170,13 @@ importsFromImportDecl this_mod filtered_exports = filter not_this_mod (mi_exports iface) not_this_mod (mod,_) = mod /= this_mod - -- If the module exports anything defined in this module, just ignore it. - -- Reason: otherwise it looks as if there are two local definition sites - -- for the thing, and an error gets reported. Easiest thing is just to - -- filter them out up front. This situation only arises if a module - -- imports itself, or another module that imported it. (Necessarily, - -- this invoves a loop.) + -- If the module exports anything defined in this module, just + -- ignore it. Reason: otherwise it looks as if there are two + -- local definition sites for the thing, and an error gets + -- reported. Easiest thing is just to filter them out up + -- front. This situation only arises if a module imports + -- itself, or another module that imported it. (Necessarily, + -- this invoves a loop.) -- -- Tiresome consequence: if you say -- module A where @@ -261,13 +193,16 @@ importsFromImportDecl this_mod Just another_name -> another_name imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, is_dloc = loc, is_as = qual_mod_name } - in - -- Get the total imports, and filter them according to the import list - ifaceExportNames filtered_exports `thenM` \ total_avails -> - filterImports iface imp_spec - imp_details total_avails `thenM` \ (avail_env, gbl_env) -> + -- in + + -- Get the total exports from this module + total_avails <- ifaceExportNames filtered_exports + + -- filter the imports according to the import declaration + (new_imp_details, filtered_avails, gbl_env) <- + filterImports iface imp_spec imp_details total_avails - getDOpts `thenM` \ dflags -> + dflags <- getDOpts let -- Compute new transitive dependencies @@ -305,26 +240,28 @@ importsFromImportDecl this_mod Just (is_hiding, ls) -> not is_hiding && null ls other -> False - -- unqual_avails is the Avails that are visible in *unqualified* form - -- We need to know this so we know what to export when we see - -- module M ( module P ) where ... - -- Then we must export whatever came from P unqualified. imports = ImportAvails { - imp_env = unitUFM qual_mod_name avail_env, + imp_env = unitUFM qual_mod_name filtered_avails, imp_mods = unitModuleEnv imp_mod (imp_mod, import_all, loc), imp_orphs = orphans, imp_dep_mods = mkModDeps dependent_mods, - imp_dep_pkgs = dependent_pkgs } + imp_dep_pkgs = dependent_pkgs, + imp_parent = emptyNameEnv + } + + -- in - in -- Complain if we import a deprecated module ifOptM Opt_WarnDeprecations ( case deprecs of DeprecAll txt -> addWarn (moduleDeprec imp_mod_name txt) other -> returnM () - ) `thenM_` + ) + + let new_imp_decl = L loc (ImportDecl loc_imp_mod_name want_boot + qual_only as_mod new_imp_details) - returnM (gbl_env, imports) + returnM (new_imp_decl, gbl_env, filtered_avails, imports) warnRedundantSourceImport mod_name = ptext SLIT("Unnecessary {-# SOURCE #-} in the import of module") @@ -350,7 +287,7 @@ importsFromLocalDecls :: HsGroup RdrName -> RnM TcGblEnv importsFromLocalDecls group = do { gbl_env <- getGblEnv - ; names <- getLocalDeclBinders gbl_env group + ; avails <- getLocalDeclBinders gbl_env group ; implicit_prelude <- doptM Opt_ImplicitPrelude ; let { @@ -372,19 +309,24 @@ importsFromLocalDecls group -- Ditto in fixity decls; e.g. infix 5 : -- Sigh. It doesn't matter because it only affects the Data.Tuple really. -- The important thing is to trim down the exports. - filtered_names - | implicit_prelude = names - | otherwise = filter (not . isBuiltInSyntax) names ; + names = concatMap availNames avails; + + filtered_avails + | implicit_prelude = avails + | otherwise = filterAvails (not.isBuiltInSyntax) avails; ; this_mod = tcg_mod gbl_env ; imports = emptyImportAvails { - imp_env = unitUFM (moduleName this_mod) $ - mkNameSet filtered_names + imp_env = unitUFM (moduleName this_mod) + filtered_avails, + imp_parent = availsToNameEnv avails } } ; rdr_env' <- extendRdrEnvRn (tcg_rdr_env gbl_env) names + ; traceRn (text "local avails: " <> ppr avails) + ; returnM (gbl_env { tcg_rdr_env = rdr_env', tcg_imports = imports `plusImportAvails` tcg_imports gbl_env }) } @@ -424,7 +366,7 @@ raising a duplicate declaration error. So, we make a new name for it, but don't return it in the 'AvailInfo'. \begin{code} -getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [Name] +getLocalDeclBinders :: TcGblEnv -> HsGroup RdrName -> RnM [AvailInfo] getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, hs_tyclds = tycl_decls, hs_instds = inst_decls, @@ -432,7 +374,7 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, = do { tc_names_s <- mappM new_tc tycl_decls ; at_names_s <- mappM inst_ats inst_decls ; val_names <- mappM new_simple val_bndrs - ; return (foldr (++) val_names (tc_names_s ++ concat at_names_s)) } + ; return (val_names ++ tc_names_s ++ concat at_names_s) } where mod = tcg_mod gbl_env is_hs_boot = isHsBoot (tcg_src gbl_env) ; @@ -441,7 +383,9 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, -- In a hs-boot file, the value binders come from the -- *signatures*, and there should be no foreign binders - new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name + new_simple rdr_name = do + nm <- newTopSrcBinder mod rdr_name + return (Avail nm) sig_hs_bndrs = [nm | L _ (TypeSig nm _) <- val_sigs] val_hs_bndrs = collectHsBindLocatedBinders val_decls @@ -450,14 +394,13 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs, new_tc tc_decl | isIdxTyDecl (unLoc tc_decl) = do { main_name <- lookupFamInstDeclBndr mod main_rdr - ; sub_names <- - mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs - ; return sub_names } -- main_name is not declared here! + ; sub_names <- mappM (newTopSrcBinder mod) sub_rdrs + ; return (AvailTC main_name sub_names) } + -- main_name is not bound here! | otherwise - = do { main_name <- newTopSrcBinder mod Nothing main_rdr - ; sub_names <- - mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs - ; return (main_name : sub_names) } + = do { main_name <- newTopSrcBinder mod main_rdr + ; sub_names <- mappM (newTopSrcBinder mod) sub_rdrs + ; return (AvailTC main_name (main_name : sub_names)) } where (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl) @@ -478,82 +421,217 @@ available, and filters it through the import spec (if any). \begin{code} filterImports :: ModIface -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, [LIE Name]) -- Import spec; True => hiding - -> NameSet -- What's available - -> RnM (NameSet, -- What's imported (qualified or unqualified) + -> Maybe (Bool, [LIE RdrName]) -- Import spec; True => hiding + -> [AvailInfo] -- What's available + -> RnM (Maybe (Bool, [LIE Name]), -- Import spec w/ Names + [AvailInfo], -- What's imported GlobalRdrEnv) -- Same again, but in GRE form - - -- Complains if import spec mentions things that the module doesn't export - -- Warns/informs if import spec contains duplicates. -mkGenericRdrEnv decl_spec names +filterImports iface decl_spec Nothing all_avails + = return (Nothing, all_avails, mkGenericRdrEnv decl_spec all_avails) + +filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails + = do + -- check for errors, convert RdrNames to Names + opt_indexedtypes <- doptM Opt_IndexedTypes + items1 <- mapM (lookup_lie opt_indexedtypes) import_items + + let -- build the AvailInfo corresponding to each import item. + items2 = [ (ie, filterAvailByIE (unLoc ie) av) + | (ie,av) <- concat items1 ] + + -- eliminate duplicates + avails = nubAvails (map snd items2) + + -- the new import spec, with Names instead of RdrNames + imp_spec_out = Just (want_hiding, map fst items2) + + case want_hiding of + True -> + let + keep n = not (n `elemNameSet` availsToNameSet avails) + pruned_avails = filterAvails keep all_avails + in do + traceRn (text "pruned_avails: " <> ppr pruned_avails) + return (imp_spec_out, pruned_avails, + mkGenericRdrEnv decl_spec pruned_avails) + + False -> + let + gres = concat [ mkGlobalRdrEltsFromIE decl_spec lie avail + | (lie, avail) <- items2 ] + in do + traceRn (text "imported avails: " <> ppr avails) + return (imp_spec_out, avails, mkGlobalRdrEnv gres) + where + -- This environment is how we map names mentioned in the import + -- list to the actual Name they correspond to, and the family + -- that the Name belongs to (an AvailInfo). + -- + -- This env will have entries for data constructors too, + -- they won't make any difference because naked entities like T + -- in an import list map to TcOccs, not VarOccs. + occ_env :: OccEnv (Name,AvailInfo) + occ_env = mkOccEnv [ (nameOccName n, (n,a)) + | a <- all_avails, n <- availNames a ] + + lookup_lie :: Bool -> LIE RdrName -> TcRn [(LIE Name, AvailInfo)] + lookup_lie opt_indexedtypes (L loc ieRdr) + = do + stuff <- setSrcSpan loc $ + case lookup_ie opt_indexedtypes ieRdr of + Failed err -> addErr err >> return [] + Succeeded a -> return a + checkDodgyImport stuff + return [ (L loc ie, avail) | (ie,avail) <- stuff ] + where + -- warn when importing T(..) if T was exported absgtractly + checkDodgyImport stuff + | IEThingAll n <- ieRdr, (_, AvailTC _ [one]):_ <- stuff + = ifOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) + -- NB. use the RdrName for reporting the warning + checkDodgyImport _ + = return () + + -- For each import item, we convert its RdrNames to Names, + -- and at the same time construct an AvailInfo corresponding + -- to what is actually imported by this item. + -- Returns Nothing on error. + -- We return a list here, because in the case of an import + -- item like C, if we are hiding, then C refers to *both* a + -- type/class and a data constructor. + lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)] + lookup_ie opt_indexedtypes ie + = let bad_ie = Failed (badImportItemErr iface decl_spec ie) + + lookup_name rdrName = + case lookupOccEnv occ_env (rdrNameOcc rdrName) of + Nothing -> bad_ie + Just n -> return n + in + case ie of + IEVar n -> do + (name,avail) <- lookup_name n + return [(IEVar name, avail)] + + IEThingAll tc -> do + (name,avail) <- lookup_name tc + return [(IEThingAll name, avail)] + + IEThingAbs tc + | want_hiding -- hiding ( C ) + -- Here the 'C' can be a data constructor + -- *or* a type/class, or even both + -> let tc_name = lookup_name tc + dc_name = lookup_name (setRdrNameSpace tc srcDataName) + in + case catMaybeErr [ tc_name, dc_name ] of + [] -> bad_ie + names -> return [ (IEThingAbs n, av) | (n,av) <- names ] + | otherwise + -> do (name,avail) <- lookup_name tc + return [(IEThingAbs name, avail)] + + IEThingWith n ns -> do + (name,avail) <- lookup_name n + case avail of + AvailTC nm subnames | nm == name -> do + let env = mkOccEnv [ (nameOccName s, s) + | s <- subnames ] + let mb_children = map (lookupOccEnv env . rdrNameOcc) ns + children <- + if any isNothing mb_children + then bad_ie + else return (catMaybes mb_children) + -- check for proper import of indexed types + when (not opt_indexedtypes && any isTyConName children) $ + Failed (typeItemErr (head . filter isTyConName + $ children ) + (text "in import list")) + return [(IEThingWith name children, avail)] + _otherwise -> bad_ie + + _other -> Failed illegalImportItemErr + -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed + -- all errors. + +catMaybeErr :: [MaybeErr err a] -> [a] +catMaybeErr ms = [ a | Succeeded a <- ms ] +\end{code} + +%************************************************************************ +%* * + Import/Export Utils +%* * +%************************************************************************ + +\begin{code} +-- | make a 'GlobalRdrEnv' where all the elements point to the same +-- import declaration (useful for "hiding" imports, or imports with +-- no details). +mkGenericRdrEnv decl_spec avails = mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = Imported [imp_spec] } - | name <- nameSetToList names ] + | name <- concatMap availNames avails ] where imp_spec = ImpSpec { is_decl = decl_spec, is_item = ImpAll } -filterImports iface decl_spec Nothing all_names - = return (all_names, mkGenericRdrEnv decl_spec all_names) - -filterImports iface decl_spec (Just (want_hiding, import_items)) all_names - = mapM (addLocM get_item) import_items >>= \gres_s -> - let gres = concat gres_s - specified_names = mkNameSet (map gre_name gres) - in if not want_hiding then - return (specified_names, mkGlobalRdrEnv gres) - else let keep n = not (n `elemNameSet` specified_names) - pruned_avails = filterNameSet keep all_names - in return (pruned_avails, mkGenericRdrEnv decl_spec pruned_avails) + +-- | filters an 'AvailInfo' by the given import/export spec. +filterAvailByIE :: IE Name -> AvailInfo -> AvailInfo +filterAvailByIE (IEVar n) a@(Avail _) = a +filterAvailByIE (IEVar n) a@(AvailTC tc subs) = AvailTC tc [n] +filterAvailByIE (IEThingAbs n) a@(AvailTC _ _) = AvailTC n [n] +filterAvailByIE (IEThingAll n) a@(AvailTC tc subs) = a +filterAvailByIE (IEThingWith n ns) a@(AvailTC tc subs) = + AvailTC tc (filter (`elem` (n:ns)) subs) +filterAvailByIE _ _ = panic "filterAvailByIE" + +-- | filters 'AvailInfo's by the given predicate +filterAvails :: (Name -> Bool) -> [AvailInfo] -> [AvailInfo] +filterAvails keep avails = foldr (filterAvail keep) [] avails + +-- | filters an 'AvailInfo' by the given predicate +filterAvail :: (Name -> Bool) -> AvailInfo -> [AvailInfo] -> [AvailInfo] +filterAvail keep ie rest = + case ie of + Avail n | keep n -> ie : rest + | otherwise -> rest + AvailTC tc ns -> + let left = filter keep ns in + if null left then rest else AvailTC tc left : rest + +-- | combines 'AvailInfo's from the same family +nubAvails :: [AvailInfo] -> [AvailInfo] +nubAvails avails = nameEnvElts (foldr add emptyNameEnv avails) + where + add avail env = extendNameEnv_C comb_avails env (availName avail) avail + comb_avails (AvailTC tc subs1) (AvailTC _ subs2) + = AvailTC tc (nub (subs1 ++ subs2)) + comb_avails avail _ = avail + +-- | Given an import/export spec, construct the appropriate 'GlobalRdrElt's. +mkGlobalRdrEltsFromIE :: ImpDeclSpec -> LIE Name -> AvailInfo -> [GlobalRdrElt] +mkGlobalRdrEltsFromIE decl_spec (L loc ie) avail = + case ie of + IEVar name -> + [mk_explicit_gre name] + IEThingAbs name -> + [mk_explicit_gre name] + IEThingAll name | AvailTC _ subs <- avail -> + mk_explicit_gre name : map mk_implicit_gre subs + IEThingWith name subs -> + mk_explicit_gre name : map mk_explicit_gre subs + _ -> + panic "mkGlobalRdrEltsFromIE" where - sub_env :: NameEnv [Name] -- Classify each name by its parent - sub_env = mkSubNameEnv all_names + mk_explicit_gre = mk_gre True + mk_implicit_gre = mk_gre False - succeed_with :: Bool -> [Name] -> RnM [GlobalRdrElt] - succeed_with all_explicit names - = do { loc <- getSrcSpanM - ; returnM (map (mk_gre loc) names) } - where - mk_gre loc name = GRE { gre_name = name, - gre_prov = Imported [imp_spec] } + mk_gre explicit name = GRE { gre_name = name, + gre_prov = Imported [imp_spec] } where imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec } item_spec = ImpSome { is_explicit = explicit, is_iloc = loc } - explicit = all_explicit || isNothing (nameParent_maybe name) - - get_item :: IE Name -> RnM [GlobalRdrElt] - -- Empty result for a bad item. - -- Singleton result is typical case. - -- Can have two when we are hiding, and mention C which might be - -- both a class and a data constructor. - get_item item@(IEModuleContents _) - -- This case should be filtered out by 'rnImports'. - = panic "filterImports: IEModuleContents?" - - get_item (IEThingAll name) - = case subNames sub_env name of - [] -> -- This occurs when you import T(..), but - -- only export T abstractly. - do ifOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn name)) - succeed_with False [name] - names -> succeed_with False (name:names) - - get_item (IEThingAbs name) - = succeed_with True [name] - - get_item (IEThingWith name names) - = do { optIdxTypes <- doptM Opt_IndexedTypes - ; when (not optIdxTypes && any isTyConName names) $ - addErr (typeItemErr (head . filter isTyConName $ names ) - (text "in import list")) - ; succeed_with True (name:names) } - get_item (IEVar name) - = succeed_with True [name] - get_item (IEGroup _ _) - = succeed_with False [] - get_item (IEDoc _) - = succeed_with False [] - get_item (IEDocNamed _) - = succeed_with False [] \end{code} @@ -578,10 +656,10 @@ it re-exports @GHC@, which includes @takeMVar#@, whose type includes \begin{code} type ExportAccum -- The type of the accumulating parameter of -- the main worker function in rnExports - = ([ModuleName], -- 'module M's seen so far + = ([LIE Name], -- export items with Names ExportOccMap, -- Tracks exported occurrence names - NameSet) -- The accumulated exported stuff -emptyExportAccum = ([], emptyOccEnv, emptyNameSet) + [AvailInfo]) -- The accumulated exported stuff +emptyExportAccum = ([], emptyOccEnv, []) type ExportOccMap = OccEnv (Name, IE RdrName) -- Tracks what a particular exported OccName @@ -589,70 +667,17 @@ type ExportOccMap = OccEnv (Name, IE RdrName) -- it came from. It's illegal to export two distinct things -- that have the same occurrence name -rnExports :: Maybe [LIE RdrName] - -> RnM (Maybe [LIE Name]) -rnExports Nothing = return Nothing -rnExports (Just exports) - = do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv - let sub_env :: NameEnv [Name] -- Classify each name by its parent - sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env) - rnExport (IEVar rdrName) - = do name <- lookupGlobalOccRn rdrName - return (IEVar name) - rnExport (IEThingAbs rdrName) - = do name <- lookupGlobalOccRn rdrName - return (IEThingAbs name) - rnExport (IEThingAll rdrName) - = do name <- lookupGlobalOccRn rdrName - return (IEThingAll name) - rnExport ie@(IEThingWith rdrName rdrNames) - = do name <- lookupGlobalOccRn rdrName - if isUnboundName name - then return (IEThingWith name []) - else do - let env = mkOccEnv [(nameOccName s, s) | s <- subNames sub_env name] - mb_names = map (lookupOccEnv env . rdrNameOcc) rdrNames - if any isNothing mb_names - then do addErr (exportItemErr ie) - return (IEThingWith name []) - else do let names = catMaybes mb_names - optIdxTypes <- doptM Opt_IndexedTypes - when (not optIdxTypes && any isTyConName names) $ - addErr (typeItemErr ( head - . filter isTyConName - $ names ) - (text "in export list")) - return (IEThingWith name names) - rnExport (IEModuleContents mod) - = return (IEModuleContents mod) - rnExport (IEGroup lev doc) - = do rn_doc <- rnHsDoc doc - return (IEGroup lev rn_doc) - rnExport (IEDoc doc) - = do rn_doc <- rnHsDoc doc - return (IEDoc rn_doc) - rnExport (IEDocNamed str) - = return (IEDocNamed str) - - rn_exports <- mapM (wrapLocM rnExport) exports - return (Just rn_exports) - -filterOutDocs = filter notDoc - where - notDoc (L _ (IEGroup _ _)) = False - notDoc (L _ (IEDoc _)) = False - notDoc (L _ (IEDocNamed _)) = False - notDoc _ = True - -mkExportNameSet :: Bool -- False => no 'module M(..) where' header at all - -> Maybe ([LIE Name], [LIE RdrName]) -- Nothing => no explicit export list - -> RnM NameSet +rnExports :: Bool -- False => no 'module M(..) where' header at all + -> Maybe [LIE RdrName] -- Nothing => no explicit export list + -> RnM (Maybe [LIE Name], [AvailInfo]) + -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope -mkExportNameSet explicit_mod exports - = do TcGblEnv { tcg_rdr_env = rdr_env, +rnExports explicit_mod exports + = do TcGblEnv { tcg_mod = this_mod, + tcg_rdr_env = rdr_env, tcg_imports = imports } <- getGblEnv -- If the module header is omitted altogether, then behave @@ -662,95 +687,160 @@ mkExportNameSet explicit_mod exports -- Reason: don't want to complain about 'main' not in scope -- in interactive mode ghc_mode <- getGhcMode - real_exports <- case () of - () | explicit_mod - -> return exports - | ghc_mode == Interactive - -> return Nothing - | otherwise - -> do mainName <- lookupGlobalOccRn main_RDR_Unqual - return (Just ([noLoc (IEVar mainName)] - ,[noLoc (IEVar main_RDR_Unqual)])) - -- ToDo: the 'noLoc' here is unhelpful if 'main' turns out to be out of scope - - -- we don't want to include Haddock comments - let real_exports' = fmap (\(a,b) -> (filterOutDocs a, filterOutDocs b)) real_exports - - exports_from_avail real_exports' rdr_env imports - - -exports_from_avail Nothing rdr_env imports - = -- Export all locally-defined things - -- We do this by filtering the global RdrEnv, - -- keeping only things that are locally-defined - return (mkNameSet [ gre_name gre - | gre <- globalRdrEnvElts rdr_env, - isLocalGRE gre ]) - -exports_from_avail (Just (items,origItems)) rdr_env (ImportAvails { imp_env = imp_env }) - = do (_, _, exports) <- foldlM do_litem emptyExportAccum (zip items origItems) - return exports + real_exports <- + case () of + () | explicit_mod + -> return exports + | ghc_mode == Interactive + -> return Nothing + | otherwise + -> do mainName <- lookupGlobalOccRn main_RDR_Unqual + return (Just ([noLoc (IEVar main_RDR_Unqual)])) + -- ToDo: the 'noLoc' here is unhelpful if 'main' turns + -- out to be out of scope + + (exp_spec, avails) <- exports_from_avail real_exports rdr_env + imports this_mod + return (exp_spec, nubAvails avails) + -- combine families + +exports_from_avail :: Maybe [LIE RdrName] + -- Nothing => no explicit export list + -> GlobalRdrEnv + -> ImportAvails + -> Module + -> RnM (Maybe [LIE Name], [AvailInfo]) + +exports_from_avail Nothing rdr_env imports this_mod + = -- the same as (module M) where M is the current module name, + -- so that's how we handle it. + let + names = [ gre_name gre | gre <- globalRdrEnvElts rdr_env, + isLocalGRE gre ] + avails = map (lookupNameEnv_NF (imp_parent imports)) names + in + return (Nothing, avails) + +exports_from_avail (Just rdr_items) rdr_env imports this_mod + = do traceRn (text "parent: " <> ppr (imp_parent imports)) + (ie_names, _, exports) <- foldlM do_litem emptyExportAccum rdr_items + return (Just ie_names, exports) where - sub_env :: NameEnv [Name] -- Classify each name by its parent - sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env) - - do_litem :: ExportAccum -> (LIE Name, LIE RdrName) -> RnM ExportAccum - do_litem acc (ieName, ieRdr) - = addLocM (exports_from_item acc (unLoc ieRdr)) ieName + do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum + do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) - exports_from_item :: ExportAccum -> IE RdrName -> IE Name -> RnM ExportAccum - exports_from_item acc@(mods, occs, exports) ieRdr@(IEModuleContents mod) ie + exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum + exports_from_item acc@(ie_names, occs, exports) + (L loc ie@(IEModuleContents mod)) | mod `elem` mods -- Duplicate export of M = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; warnIf warn_dup_exports (dupModuleExport mod) ; returnM acc } | otherwise - = case lookupUFM imp_env mod of + = case lookupUFM (imp_env imports) mod of Nothing -> do addErr (modExportErr mod) return acc - Just names - -> do let new_exports = filterNameSet (inScopeUnqual rdr_env) names - -- This check_occs not only finds conflicts between this item - -- and others, but also internally within this item. That is, - -- if 'M.x' is in scope in several ways, we'll have several - -- members of mod_avails with the same OccName. - occs' <- check_occs ieRdr occs (nameSetToList new_exports) - return (mod:mods, occs', exports `unionNameSets` new_exports) - - exports_from_item acc@(mods, occs, exports) ieRdr ie - = if isUnboundName (ieName ie) - then return acc -- Avoid error cascade - else let new_exports = filterAvail ie sub_env in - do -- checkErr (not (null (drop 1 new_exports))) (exportItemErr ie) - checkForDodgyExport ie new_exports - occs' <- check_occs ieRdr occs new_exports - return (mods, occs', addListToNameSet exports new_exports) + Just avails + -> do traceRn (text "mod avails: " <> ppr mod <+> ppr avails) + let avails' = filterAvails (inScopeUnqual rdr_env) $ + nubAvails avails + new_exps = concatMap availNames avails' + + occs' <- check_occs ie occs new_exps + -- This check_occs not only finds conflicts + -- between this item and others, but also + -- internally within this item. That is, if + -- 'M.x' is in scope in several ways, we'll have + -- several members of mod_avails with the same + -- OccName. + return (L loc (IEModuleContents mod) : ie_names, + occs', avails' ++ exports) + where + mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ] + + exports_from_item acc@(lie_names, occs, exports) (L loc ie) + = do new_ie <- lookup_ie ie + let ie_name = ieName new_ie + if isUnboundName ie_name + then return acc -- Avoid error cascade + else do + if isDoc new_ie -- deal with docs + then return (L loc new_ie : lie_names, occs, exports) + else do + traceRn (text "lookup_avail: " <> ppr (lookup_avail ie_name)) + let avail = filterAvailByIE new_ie (lookup_avail ie_name) + new_exports = case new_ie of + IEThingWith n ns -> n : ns + _ -> availNames avail + -- ^^^ an IEThingWith might contain duplicates + -- whereas the avail doesn't, but we want + -- duplicates to be noticed by check_occs below. + -- checkErr (not (null (drop 1 new_exports))) (exportItemErr ie) + checkForDodgyExport new_ie new_exports + occs' <- check_occs ie occs new_exports + return (L loc new_ie : lie_names, occs', avail : exports) -------------------------------- -filterAvail :: IE Name -- Wanted - -> NameEnv [Name] -- Maps type/class names to their sub-names - -> [Name] - -filterAvail (IEVar n) subs = [n] -filterAvail (IEThingAbs n) subs = [n] -filterAvail (IEThingAll n) subs = n : subNames subs n -filterAvail (IEThingWith n ns) subs = n : ns -filterAvail (IEModuleContents _) _ = panic "filterAvail" - -subNames :: NameEnv [Name] -> Name -> [Name] -subNames env n = lookupNameEnv env n `orElse` [] - -mkSubNameEnv :: NameSet -> NameEnv [Name] --- Maps types and classes to their constructors/classops respectively --- This mapping just makes it easier to deal with A(..) export items -mkSubNameEnv names - = foldNameSet add_name emptyNameEnv names - where - add_name name env - | Just parent <- nameParent_maybe name - = extendNameEnv_C (\ns _ -> name:ns) env parent [name] - | otherwise = env + lookup_avail :: Name -> AvailInfo + lookup_avail name = + case lookupNameEnv avail_env name of + Nothing -> pprPanic "rnExports:lookup_avail" (ppr name) + Just a -> a + where avail_env = imp_parent imports + + lookup_ie :: IE RdrName -> RnM (IE Name) + + lookup_ie (IEVar rdr) + = do name <- lookupGlobalOccRn rdr + return (IEVar name) + + lookup_ie (IEThingAbs rdr) + = do name <- lookupGlobalOccRn rdr + return (IEThingAbs name) + + lookup_ie (IEThingAll rdr) + = do name <- lookupGlobalOccRn rdr + return (IEThingAll name) + + lookup_ie ie@(IEThingWith rdr sub_rdrs) + = do name <- lookupGlobalOccRn rdr + if isUnboundName name + then return (IEThingWith name []) + else do + let avail = lookup_avail name + env = mkOccEnv [ (nameOccName s, s) + | AvailTC _ subnames <- [avail], + s <- subnames ] + let mb_names = map (lookupOccEnv env . rdrNameOcc) sub_rdrs + if any isNothing mb_names + then do addErr (exportItemErr ie) + return (IEThingWith name []) + else do let names = catMaybes mb_names + optIdxTypes <- doptM Opt_IndexedTypes + when (not optIdxTypes && any isTyConName names) $ + addErr (typeItemErr ( head + . filter isTyConName + $ names ) + (text "in export list")) + return (IEThingWith name (catMaybes mb_names)) + + lookup_ie (IEGroup lev doc) + = do rn_doc <- rnHsDoc doc + return (IEGroup lev rn_doc) + lookup_ie (IEDoc doc) + = do rn_doc <- rnHsDoc doc + return (IEDoc rn_doc) + lookup_ie (IEDocNamed str) + = return (IEDocNamed str) + + lookup_ie (IEModuleContents _) + = panic "rnExports:lookup_ie" -- caught earlier + + +isDoc (IEDoc _) = True +isDoc (IEDocNamed _) = True +isDoc (IEGroup _ _) = True +isDoc _ = False ------------------------------- inScopeUnqual :: GlobalRdrEnv -> Name -> Bool @@ -811,9 +901,11 @@ reportDeprecations dflags tcg_env -- Report on all deprecated uses; hence allUses all_gres = globalRdrEnvElts (tcg_rdr_env tcg_env) + avail_env = imp_parent (tcg_imports tcg_env) + check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_)}) | name `elemNameSet` used_names - , Just deprec_txt <- lookupDeprec dflags hpt pit name + , Just deprec_txt <- lookupDeprec dflags hpt pit avail_env name = addWarnAt (importSpecLoc imp_spec) (sep [ptext SLIT("Deprecated use of") <+> pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> @@ -836,8 +928,9 @@ reportDeprecations dflags tcg_env -- interface lookupDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable + -> NameEnv AvailInfo -- parent info -> Name -> Maybe DeprecTxt -lookupDeprec dflags hpt pit n +lookupDeprec dflags hpt pit avail_env n = case lookupIfaceByModule dflags hpt pit (nameModule n) of Just iface -> mi_dep_fn iface n `seqMaybe` -- Bleat if the thing, *or mi_dep_fn iface (nameParent n) -- its parent*, is deprec'd @@ -849,6 +942,10 @@ lookupDeprec dflags hpt pit n | otherwise -> pprPanic "lookupDeprec" (ppr n) -- By now all the interfaces should have been loaded + where + nameParent n = case lookupNameEnv avail_env n of + Just (AvailTC parent _) -> parent + _ -> n gre_is_used :: NameSet -> GlobalRdrElt -> Bool gre_is_used used_names gre = gre_name gre `elemNameSet` used_names @@ -876,6 +973,11 @@ reportUnusedNames export_decls gbl_env -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used -- Hence findUses + avail_env = imp_parent (tcg_imports gbl_env) + nameParent_maybe n = case lookupNameEnv avail_env n of + Just (AvailTC tc _) | tc /= n -> Just tc + _otherwise -> Nothing + all_used_names = used_names `unionNameSets` mkNameSet (mapCatMaybes nameParent_maybe (nameSetToList used_names)) -- A use of C implies a use of T, @@ -1144,6 +1246,8 @@ badImportItemErr iface decl_spec ie source_import | mi_boot iface = ptext SLIT("(hi-boot interface)") | otherwise = empty +illegalImportItemErr = ptext SLIT("Illegal import item") + dodgyImportWarn item = dodgyMsg (ptext SLIT("import")) item dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index fcf41e5ff6..59d60ebf59 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -615,7 +615,7 @@ newDFunName clas (ty:_) loc occNameString (getDFunTyKey ty) dfun_occ = mkDFunOcc info_string is_boot index - ; newGlobalBinder mod dfun_occ Nothing loc } + ; newGlobalBinder mod dfun_occ loc } newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} @@ -630,7 +630,7 @@ newFamInstTyConName tc_name loc = do { index <- nextDFunIndex ; mod <- getModule ; let occ = nameOccName tc_name - ; newGlobalBinder mod (mkInstTyTcOcc index occ) Nothing loc } + ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc } \end{code} diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs index 6c801895bf..4019feb8e6 100644 --- a/compiler/typecheck/TcForeign.lhs +++ b/compiler/typecheck/TcForeign.lhs @@ -228,7 +228,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) = getModule `thenM` \ mod -> let gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) - Nothing (srcSpanStart loc) + (srcSpanStart loc) id = mkExportedLocalId gnm sig_ty bind = L loc (VarBind id rhs) in diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index d1333b3833..a1592ec2a4 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -51,12 +51,11 @@ import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcIface ( tcExtCoreBindings, tcHiBootIface ) import MkIface ( tyThingToIfaceDecl ) -import IfaceSyn ( checkBootDecl, IfaceExtName(..) ) +import IfaceSyn import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules ) import RnNames ( importsFromLocalDecls, rnImports, rnExports, - mkRdrEnvAndImports, mkExportNameSet, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) @@ -70,8 +69,9 @@ import Module import UniqFM ( elemUFM, eltsUFM ) import OccName ( mkVarOccFS, plusOccEnv ) import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, - nameModule, nameOccName, isImplicitName, mkExternalName ) + nameModule, nameOccName, mkExternalName ) import NameSet +import NameEnv import TyCon ( tyConHasGenerics ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) @@ -79,10 +79,10 @@ import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, HscEnv(..), ExternalPackageState(..), IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, - ForeignStubs(NoStubs), + ForeignStubs(NoStubs), availsToNameSet, TypeEnv, lookupTypeEnv, hptInstances, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, - emptyFixityEnv + emptyFixityEnv, GenAvailInfo(..) ) import Outputable @@ -121,7 +121,6 @@ import {- Kind parts of -} Type ( Kind ) import Var ( globaliseId ) import Name ( isBuiltInSyntax, isInternalName ) import OccName ( isTcOcc ) -import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, bindIOName, thenIOName, returnIOName ) import HscTypes ( InteractiveContext(..), @@ -171,8 +170,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax setSrcSpan loc $ do { -- Deal with imports; - rn_imports <- rnImports import_decls ; - (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ; + (rn_imports, rdr_env, imports) <- rnImports import_decls ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports @@ -211,6 +209,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Fail if there are any errors so far -- The error printing (if needed) takes advantage -- of the tcg_env we have now set + traceIf (text "rdr_env: " <+> ppr rdr_env) ; failIfErrsM ; -- Load any orphan-module interfaces, so that @@ -235,7 +234,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax reportDeprecations (hsc_dflags hsc_env) tcg_env ; -- Process the export list - rn_exports <- rnExports export_ies ; + (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ; -- Rename the Haddock documentation header rn_module_doc <- rnMbHsDoc maybe_doc ; @@ -244,10 +243,6 @@ tcRnModule hsc_env hsc_src save_rn_syntax rn_description <- rnMbHsDoc (hmi_description module_info) ; let { rn_module_info = module_info { hmi_description = rn_description } } ; - let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ; - exports <- mkExportNameSet (isJust maybe_mod) - (liftM2' (,) rn_exports export_ies) ; - -- Check whether the entire module is deprecated -- This happens only once per module let { mod_deprecs = checkModDeprec mod_deprec } ; @@ -257,7 +252,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcg_rn_exports = if save_rn_syntax then rn_exports else Nothing, - tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports, + tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet exports), tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` mod_deprecs, tcg_doc = rn_module_doc, @@ -321,7 +316,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Wrap up let { bndrs = bindersOfBinds core_binds ; - my_exports = mkNameSet (map idName bndrs) ; + my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; @@ -530,7 +525,7 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) checkHiBootIface (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, - tcg_type_env = local_type_env }) + tcg_type_env = local_type_env, tcg_imports = imports }) (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, md_types = boot_type_env }) = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ; @@ -548,8 +543,8 @@ checkHiBootIface | no_check name = return () | Just real_thing <- lookupTypeEnv local_type_env name - = do { let boot_decl = tyThingToIfaceDecl ext_nm boot_thing - real_decl = tyThingToIfaceDecl ext_nm real_thing + = do { let boot_decl = tyThingToIfaceDecl boot_thing + real_decl = tyThingToIfaceDecl real_thing ; checkTc (checkBootDecl boot_decl real_decl) (bootMisMatch boot_thing boot_decl real_decl) } -- The easiest way to check compatibility is to convert to @@ -559,14 +554,16 @@ checkHiBootIface where name = getName boot_thing - ext_nm name = ExtPkg (nameModule name) (nameOccName name) - -- Just enough to compare; no versions etc needed + avail_env = imp_parent imports + is_implicit name = case lookupNameEnv avail_env name of + Just (AvailTC tc _) | tc /= name -> True + _otherwise -> False no_check name = isWiredInName name -- No checking for wired-in names. In particular, -- 'error' is handled by a rather gross hack -- (see comments in GHC.Err.hs-boot) || name `elem` dfun_names - || isImplicitName name -- Has a parent, which we'll check + || is_implicit name -- Has a parent, which we'll check dfun_names = map getName boot_insts @@ -785,7 +782,7 @@ check_main ghc_mode tcg_env main_mod main_fn ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN (mkVarOccFS FSLIT("main")) - (Just main_name) (getSrcLoc main_name) + (getSrcLoc main_name) ; root_main_id = mkExportedLocalId root_main_name ty ; main_bind = noLoc (VarBind root_main_id main_expr) } diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index 12f0cf6d32..3272dea69b 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -108,7 +108,7 @@ initTc hsc_env hsc_src mod do_this tcg_fam_inst_env = emptyFamInstEnv, tcg_inst_uses = dfuns_var, tcg_th_used = th_var, - tcg_exports = emptyNameSet, + tcg_exports = [], tcg_imports = init_imports, tcg_dus = emptyDUs, tcg_rn_imports = Nothing, @@ -156,8 +156,7 @@ initTc hsc_env hsc_src mod do_this return (msgs, final_res) } where - init_imports = emptyImportAvails {imp_env = - unitUFM (moduleName mod) emptyNameSet} + init_imports = emptyImportAvails {imp_env = unitUFM (moduleName mod) []} -- Initialise tcg_imports with an empty set of bindings for -- this module, so that if we see 'module M' in the export -- list, and there are no bindings in M, we don't bleat diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 46ff1e898b..b14cab5eb7 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -74,6 +74,7 @@ import Bag import Outputable import Maybe ( mapMaybe ) import ListSetOps ( unionLists ) +import Data.List ( nub ) \end{code} @@ -163,7 +164,7 @@ data TcGblEnv -- accumulated, but never consulted until the end. -- Nevertheless, it's convenient to accumulate them along -- with the rest of the info from this module. - tcg_exports :: NameSet, -- What is exported + tcg_exports :: [AvailInfo], -- What is exported tcg_imports :: ImportAvails, -- Information about what was imported -- from where, including things bound -- in this module @@ -482,20 +483,21 @@ It is used * when processing the export list \begin{code} data ImportAvails = ImportAvails { - imp_env :: ModuleNameEnv NameSet, - -- All the things imported, classified by + imp_env :: ModuleNameEnv [AvailInfo], + -- All the things imported *unqualified*, classified by -- the *module qualifier* for its import -- e.g. import List as Foo -- would add a binding Foo |-> ...stuff from List... -- to imp_env. -- - -- We need to classify them like this so that we can figure out - -- "module M" export specifiers in an export list - -- (see 1.4 Report Section 5.1.1). Ultimately, we want to find - -- everything that is unambiguously in scope as 'M.x' - -- and where plain 'x' is (perhaps ambiguously) in scope. - -- So the starting point is all things that are in scope as 'M.x', - -- which is what this field tells us. + -- This is exactly the list of things that will be exported + -- by a 'module M' specifier in the export list. + -- (see Haskell 98 Report Section 5.2). + -- + -- Warning: there may be duplciates in this list, + -- duplicates are removed at the use site (rnExports). + -- We might consider turning this into a NameEnv at + -- some point. imp_mods :: ModuleEnv (Module, Bool, SrcSpan), -- Domain is all directly-imported modules @@ -510,6 +512,11 @@ data ImportAvails -- the interface file; if we import somethign we -- need to recompile if the export version changes -- (b) to specify what child modules to initialise + -- + -- We need a full ModuleEnv rather than a ModuleNameEnv + -- here, because we might be importing modules of the + -- same name from different packages. (currently not the case, + -- but might be in the future). imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), -- Home-package modules needed by the module being compiled @@ -526,8 +533,14 @@ data ImportAvails -- directly, or via other modules in this package, or via -- modules imported from other packages. - imp_orphs :: [Module] + imp_orphs :: [Module], -- Orphan modules below us in the import tree + + imp_parent :: NameEnv AvailInfo + -- for the names in scope in this module, tells us + -- the relationship between parents and children + -- (eg. a TyCon is the parent of its DataCons, a + -- class is the parent of its methods, etc.). } mkModDeps :: [(ModuleName, IsBootInterface)] @@ -541,20 +554,28 @@ emptyImportAvails = ImportAvails { imp_env = emptyUFM, imp_mods = emptyModuleEnv, imp_dep_mods = emptyUFM, imp_dep_pkgs = [], - imp_orphs = [] } + imp_orphs = [], + imp_parent = emptyNameEnv } plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_env = env1, imp_mods = mods1, - imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_orphs = orphs1 }) + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_orphs = orphs1, imp_parent = parent1 }) (ImportAvails { imp_env = env2, imp_mods = mods2, - imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2 }) - = ImportAvails { imp_env = plusUFM_C unionNameSets env1 env2, + imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, + imp_orphs = orphs2, imp_parent = parent2 }) + = ImportAvails { imp_env = plusUFM_C (++) env1 env2, imp_mods = mods1 `plusModuleEnv` mods2, imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, - imp_orphs = orphs1 `unionLists` orphs2 } + imp_orphs = orphs1 `unionLists` orphs2, + imp_parent = plusNameEnv_C plus_avails parent1 parent2 } where + plus_avails (AvailTC tc subs1) (AvailTC _ subs2) + = AvailTC tc (nub (subs1 ++ subs2)) + plus_avails avail _ = avail + plus_mod_dep (m1, boot1) (m2, boot2) = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) -- Check mod-names match diff --git a/compiler/typecheck/TcTyDecls.lhs b/compiler/typecheck/TcTyDecls.lhs index f16d89e77a..7d4ebfac26 100644 --- a/compiler/typecheck/TcTyDecls.lhs +++ b/compiler/typecheck/TcTyDecls.lhs @@ -20,7 +20,7 @@ import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl, isClassDecl ) import RnHsSyn ( extractHsTyNames ) import Type ( predTypeRep, tcView ) -import HscTypes ( TyThing(..), ModDetails(..) ) +import HscTypes ( TyThing(..), ModDetails(..), availsToNameSet ) import TyCon ( TyCon, tyConArity, tyConDataCons, tyConTyVars, isSynTyCon, isAlgTyCon, tyConName, isNewTyCon, isProductTyCon, newTyConRhs, @@ -215,7 +215,7 @@ calcRecFlags boot_details tyclss is_rec n | n `elemNameSet` rec_names = Recursive | otherwise = NonRecursive - boot_name_set = md_exports boot_details + boot_name_set = availsToNameSet (md_exports boot_details) rec_names = boot_name_set `unionNameSets` nt_loop_breakers `unionNameSets` prod_loop_breakers diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs index 09370ed1e0..ca1b1a6815 100644 --- a/compiler/types/Coercion.lhs +++ b/compiler/types/Coercion.lhs @@ -392,7 +392,7 @@ unsafeCoercionTyCon -- ...and their names mkCoConName occ key coCon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ) - key Nothing (ATyCon coCon) BuiltInSyntax + key (ATyCon coCon) BuiltInSyntax transCoercionTyConName = mkCoConName FSLIT("trans") transCoercionTyConKey transCoercionTyCon symCoercionTyConName = mkCoConName FSLIT("sym") symCoercionTyConKey symCoercionTyCon diff --git a/compiler/types/TyCon.lhs b/compiler/types/TyCon.lhs index f03fb8952e..d91effeada 100644 --- a/compiler/types/TyCon.lhs +++ b/compiler/types/TyCon.lhs @@ -10,7 +10,8 @@ module TyCon( PrimRep(..), tyConPrimRep, - AlgTyConRhs(..), visibleDataCons, AlgTyConParent(..), + AlgTyConRhs(..), visibleDataCons, + AlgTyConParent(..), hasParent, SynTyConRhs(..), isFunTyCon, isUnLiftedTyCon, isProductTyCon, @@ -22,6 +23,7 @@ module TyCon( isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConCo_maybe, isHiBootTyCon, isSuperKindTyCon, isCoercionTyCon_maybe, isCoercionTyCon, + isImplicitTyCon, tcExpandTyCon_maybe, coreExpandTyCon_maybe, @@ -275,6 +277,10 @@ data AlgTyConParent = -- An ordinary type constructor has no parent. -- the representation type -- with the type instance +hasParent :: AlgTyConParent -> Bool +hasParent NoParentTyCon = False +hasParent _other = True + data SynTyConRhs = OpenSynTyCon Kind -- Type family: *result* kind given | SynonymTyCon Type -- Mentioning head type vars. Acts as a template for @@ -662,8 +668,16 @@ isCoercionTyCon_maybe (CoercionTyCon {tyConArity = ar, coKindFun = rule}) = Just (ar, rule) isCoercionTyCon_maybe other = Nothing +isCoercionTyCon :: TyCon -> Bool isCoercionTyCon (CoercionTyCon {}) = True isCoercionTyCon other = False + +isImplicitTyCon :: TyCon -> Bool +isImplicitTyCon SynTyCon{} = False +isImplicitTyCon AlgTyCon{algTcParent = parent} = hasParent parent +isImplicitTyCon other = True + -- catches: FunTyCon, TupleTyCon, PrimTyCon, + -- CoercionTyCon, SuperKindTyCon \end{code} diff --git a/compiler/types/TypeRep.lhs b/compiler/types/TypeRep.lhs index aa1c1fad2f..9110d68ad8 100644 --- a/compiler/types/TypeRep.lhs +++ b/compiler/types/TypeRep.lhs @@ -354,7 +354,6 @@ funTyConName = mkPrimTyConName FSLIT("(->)") funTyConKey funTyCon mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkOccNameFS tcName occ) key - Nothing -- No parent object (ATyCon tycon) BuiltInSyntax -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax, diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 7a1ca515b7..1d5ab0e5ed 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -28,6 +28,8 @@ module Binary isEOFBin, + putAt, getAt, + -- for writing instances: putByte, getByte, @@ -41,9 +43,9 @@ module Binary getByteArray, putByteArray, - getBinFileWithDict, -- :: Binary a => FilePath -> IO a - putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO () - + UserData(..), getUserData, setUserData, + newReadState, newWriteState, + putDictionary, getDictionary, ) where #include "HsVersions.h" @@ -51,6 +53,7 @@ module Binary -- The *host* architecture version: #include "MachDeps.h" +import {-# SOURCE #-} Name (Name) import FastString import Unique import Panic @@ -68,7 +71,6 @@ import Data.IORef import Data.Char ( ord, chr ) import Data.Array.Base ( unsafeRead, unsafeWrite ) import Control.Monad ( when ) -import Control.Exception ( throwDyn ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) import System.IO.Error ( mkIOError, eofErrorType ) @@ -562,106 +564,57 @@ lazyGet bh = do seekBin bh p -- skip over the object for now return a --- -------------------------------------------------------------- --- Main wrappers: getBinFileWithDict, putBinFileWithDict --- --- This layer is built on top of the stuff above, --- and should not know anything about BinHandles --- -------------------------------------------------------------- - -initBinMemSize = (1024*1024) :: Int - -#if WORD_SIZE_IN_BITS == 32 -binaryInterfaceMagic = 0x1face :: Word32 -#elif WORD_SIZE_IN_BITS == 64 -binaryInterfaceMagic = 0x1face64 :: Word32 -#endif - -getBinFileWithDict :: Binary a => FilePath -> IO a -getBinFileWithDict file_path = do - bh <- Binary.readBinMem file_path - - -- Read the magic number to check that this really is a GHC .hi file - -- (This magic number does not change when we change - -- GHC interface file format) - magic <- get bh - when (magic /= binaryInterfaceMagic) $ - throwDyn (ProgramError ( - "magic number mismatch: old/corrupt interface file?")) - - -- Read the dictionary - -- The next word in the file is a pointer to where the dictionary is - -- (probably at the end of the file) - dict_p <- Binary.get bh -- Get the dictionary ptr - data_p <- tellBin bh -- Remember where we are now - seekBin bh dict_p - dict <- getDictionary bh - seekBin bh data_p -- Back to where we were before - - -- Initialise the user-data field of bh - let bh' = setUserData bh (initReadState dict) - - -- At last, get the thing - get bh' - -putBinFileWithDict :: Binary a => FilePath -> a -> IO () -putBinFileWithDict file_path the_thing = do - bh <- openBinMem initBinMemSize - put_ bh binaryInterfaceMagic - - -- Remember where the dictionary pointer will go - dict_p_p <- tellBin bh - put_ bh dict_p_p -- Placeholder for ptr to dictionary - - -- Make some intial state - usr_state <- newWriteState - - -- Put the main thing, - put_ (setUserData bh usr_state) the_thing - - -- Get the final-state - j <- readIORef (ud_next usr_state) - fm <- readIORef (ud_map usr_state) - dict_p <- tellBin bh -- This is where the dictionary will start - - -- Write the dictionary pointer at the fornt of the file - putAt bh dict_p_p dict_p -- Fill in the placeholder - seekBin bh dict_p -- Seek back to the end of the file - - -- Write the dictionary itself - putDictionary bh j (constructDictionary j fm) - - -- And send the result to the file - writeBinMem bh file_path - -- ----------------------------------------------------------------------------- -- UserData -- ----------------------------------------------------------------------------- data UserData = - UserData { -- This field is used only when reading - ud_dict :: Dictionary, - - -- The next two fields are only used when writing - ud_next :: IORef Int, -- The next index to use - ud_map :: IORef (UniqFM (Int,FastString)) - } - -noUserData = error "Binary.UserData: no user data" + UserData { + -- for *deserialising* only: + ud_dict :: Dictionary, + ud_symtab :: SymbolTable, + + -- for *serialising* only: + ud_dict_next :: !FastMutInt, -- The next index to use + ud_dict_map :: !(IORef (UniqFM (Int,FastString))), + -- indexed by FastString + + ud_symtab_next :: !FastMutInt, -- The next index to use + ud_symtab_map :: !(IORef (UniqFM (Int,Name))) + -- indexed by Name + } -initReadState :: Dictionary -> UserData -initReadState dict = UserData{ ud_dict = dict, - ud_next = undef "next", - ud_map = undef "map" } +newReadState :: Dictionary -> IO UserData +newReadState dict = do + dict_next <- newFastMutInt + dict_map <- newIORef (undef "dict_map") + symtab_next <- newFastMutInt + symtab_map <- newIORef (undef "symtab_map") + return UserData { ud_dict = dict, + ud_symtab = undef "symtab", + ud_dict_next = dict_next, + ud_dict_map = dict_map, + ud_symtab_next = symtab_next, + ud_symtab_map = symtab_map + } newWriteState :: IO UserData newWriteState = do - j_r <- newIORef 0 - out_r <- newIORef emptyUFM - return (UserData { ud_dict = panic "dict", - ud_next = j_r, - ud_map = out_r }) - + dict_next <- newFastMutInt + writeFastMutInt dict_next 0 + dict_map <- newIORef emptyUFM + symtab_next <- newFastMutInt + writeFastMutInt symtab_next 0 + symtab_map <- newIORef emptyUFM + return UserData { ud_dict = undef "dict", + ud_symtab = undef "symtab", + ud_dict_next = dict_next, + ud_dict_map = dict_map, + ud_symtab_next = symtab_next, + ud_symtab_map = symtab_map + } + +noUserData = undef "UserData" undef s = panic ("Binary.UserData: no " ++ s) @@ -672,10 +625,10 @@ undef s = panic ("Binary.UserData: no " ++ s) type Dictionary = Array Int FastString -- The dictionary -- Should be 0-indexed -putDictionary :: BinHandle -> Int -> Dictionary -> IO () +putDictionary :: BinHandle -> Int -> UniqFM (Int,FastString) -> IO () putDictionary bh sz dict = do put_ bh sz - mapM_ (putFS bh) (elems dict) + mapM_ (putFS bh) (elems (array (0,sz-1) (eltsUFM dict))) getDictionary :: BinHandle -> IO Dictionary getDictionary bh = do @@ -683,8 +636,14 @@ getDictionary bh = do elems <- sequence (take sz (repeat (getFS bh))) return (listArray (0,sz-1) elems) -constructDictionary :: Int -> UniqFM (Int,FastString) -> Dictionary -constructDictionary j fm = array (0,j-1) (eltsUFM fm) +--------------------------------------------------------- +-- The Symbol Table +--------------------------------------------------------- + +-- On disk, the symbol table is an array of IfaceExtName, when +-- reading it in we turn it into a SymbolTable. + +type SymbolTable = Array Int Name --------------------------------------------------------- -- Reading and writing FastStrings @@ -739,16 +698,18 @@ instance Binary PackageId where instance Binary FastString where put_ bh f@(FastString id l _ fp _) = case getUserData bh of { - UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do + UserData { ud_dict_next = j_r, + ud_dict_map = out_r, + ud_dict = dict} -> do out <- readIORef out_r let uniq = getUnique f case lookupUFM out uniq of Just (j,f) -> put_ bh j Nothing -> do - j <- readIORef j_r + j <- readFastMutInt j_r put_ bh j - writeIORef j_r (j+1) - writeIORef out_r (addToUFM out uniq (j,f)) + writeFastMutInt j_r (j+1) + writeIORef out_r $! addToUFM out uniq (j,f) } get bh = do diff --git a/compiler/utils/IOEnv.hs b/compiler/utils/IOEnv.hs index e1dfdb400b..8116effb33 100644 --- a/compiler/utils/IOEnv.hs +++ b/compiler/utils/IOEnv.hs @@ -17,7 +17,7 @@ module IOEnv ( getEnv, setEnv, updEnv, runIOEnv, unsafeInterleaveM, - tryM, tryAllM, fixM, + tryM, tryAllM, tryMostM, fixM, -- I/O operations ioToIOEnv, @@ -25,7 +25,7 @@ module IOEnv ( ) where #include "HsVersions.h" -import Panic ( try, tryUser, Exception(..) ) +import Panic ( try, tryUser, tryMost, Exception(..) ) import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef ) import UNSAFE_IO ( unsafeInterleaveIO ) import FIX_IO ( fixIO ) @@ -100,6 +100,9 @@ tryAllM :: IOEnv env r -> IOEnv env (Either Exception r) -- even a pattern-match failure is a programmer error tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env)) +tryMostM :: IOEnv env r -> IOEnv env (Either Exception r) +tryMostM (IOEnv thing) = IOEnv (\ env -> tryMost (thing env)) + --------------------------- unsafeInterleaveM :: IOEnv env a -> IOEnv env a unsafeInterleaveM (IOEnv m) = IOEnv (\ env -> unsafeInterleaveIO (m env)) |