From b00b5bc04ff36a551552470060064f0b7d84ca30 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Wed, 11 Oct 2006 12:05:18 +0000 Subject: [PATCH] Interface file optimisation and removal of nameParent This large commit combines several interrelated changes: - IfaceSyn now contains actual Names rather than the special IfaceExtName type. The binary interface file contains a symbol table of Names, where each entry is a (package, ModuleName, OccName) triple. Names in the IfaceSyn point to entries in the symbol table. This reduces the size of interface files, which should hopefully improve performance (not measured yet). The toIfaceXXX functions now do not need to pass around a function from Name -> IfaceExtName, which makes that code simpler. - Names now do not point directly to their parents, and the nameParent operation has gone away. It turned out to be hard to keep this information consistent in practice, and the parent info was only valid in some Names. Instead we made the following changes: * ImportAvails contains a new field imp_parent :: NameEnv AvailInfo which gives the family info for any Name in scope, and is used by the renamer when renaming export lists, amongst other things. This info is thrown away after renaming. * The mi_ver_fn field of ModIface now maps to (OccName,Version) instead of just Version, where the OccName is the parent name. This mapping is used when constructing the usage info for dependent modules. There may be entries in mi_ver_fn for things that are not in scope, whereas imp_parent only deals with in-scope things. * The md_exports field of ModDetails now contains [AvailInfo] rather than NameSet. This gives us family info for the exported names of a module. Also: - ifaceDeclSubBinders moved to IfaceSyn (seems like the right place for it). - heavily refactored renaming of import/export lists. - Unfortunately external core is now broken, as it relied on IfaceSyn. It requires some attention. --- compiler/basicTypes/MkId.lhs | 4 +- compiler/basicTypes/Name.lhs | 98 +++-- compiler/basicTypes/RdrName.lhs | 5 +- compiler/codeGen/CodeGen.lhs | 2 +- compiler/deSugar/Desugar.lhs | 9 +- compiler/deSugar/DsMeta.hs | 5 +- compiler/iface/BinIface.hs | 251 ++++++++--- compiler/iface/IfaceEnv.lhs | 160 +++---- compiler/iface/IfaceSyn.lhs | 159 ++++--- compiler/iface/IfaceType.lhs | 141 ++----- compiler/iface/LoadIface.lhs | 103 +---- compiler/iface/MkIface.lhs | 558 +++++++++++++------------ compiler/iface/TcIface.lhs | 78 ++-- compiler/main/GHC.hs | 12 +- compiler/main/HscMain.lhs | 6 +- compiler/main/HscTypes.lhs | 72 ++-- compiler/main/Main.hs | 12 +- compiler/main/TidyPgm.lhs | 15 +- compiler/parser/ParserCore.y | 19 +- compiler/prelude/PrelNames.lhs | 97 ++--- compiler/prelude/TysPrim.lhs | 1 - compiler/prelude/TysWiredIn.lhs | 31 +- compiler/rename/RnEnv.lhs | 42 +- compiler/rename/RnExpr.lhs | 5 +- compiler/rename/RnNames.lhs | 830 +++++++++++++++++++++---------------- compiler/typecheck/TcEnv.lhs | 4 +- compiler/typecheck/TcForeign.lhs | 2 +- compiler/typecheck/TcRnDriver.lhs | 41 +- compiler/typecheck/TcRnMonad.lhs | 5 +- compiler/typecheck/TcRnTypes.lhs | 53 ++- compiler/typecheck/TcTyDecls.lhs | 4 +- compiler/types/Coercion.lhs | 2 +- compiler/types/TyCon.lhs | 16 +- compiler/types/TypeRep.lhs | 1 - compiler/utils/Binary.hs | 167 +++----- compiler/utils/IOEnv.hs | 7 +- 36 files changed, 1618 insertions(+), 1399 deletions(-) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index d927e16..9818eba 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 25db761..df97181 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 d487b46..2f7f7a8 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 0422a87..4c08242 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 f49a84c..29801f2 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 b4ecf01..6c04002 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 3e9895a..3e79a39 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 6175965..fe0b0cd 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 8ac4eec..a842608 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 ee37891..64d8892 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 e322276..5b19c89 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 11235ce..e99e8bf 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 fa227e6..c16846e 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 70039a9..c786cbb 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 01c27ab..0563f34 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 6bc1197..d3c5f7f 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 0dd1cbe..55234e7 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 b04830b..dc0ea7e 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 dd3d8b7..b37add3 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 36413dd..bccf84f 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 4b6832a..7a31683 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 598fa42..436b121 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 29a8791..74c9646 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 2df8e95..261969b 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 4bca4fc..e1445c7 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 fcf41e5..59d60eb 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 6c80189..4019feb 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 d1333b3..a1592ec 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 12f0cf6..3272dea 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 46ff1e8..b14cab5 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 f16d89e..7d4ebfa 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 09370ed..ca1b1a6 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 f03fb89..d91effe 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 aa1c1fa..9110d68 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 7a1ca51..1d5ab0e 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 e1dfdb4..8116eff 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)) -- 1.7.10.4