From: Simon Marlow Date: Tue, 25 Jul 2006 13:01:54 +0000 (+0000) Subject: Generalise Package Support X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=61d2625ae2e6a4cdae2ffc92df828905e81c24cc Generalise Package Support This patch pushes through one fundamental change: a module is now identified by the pair of its package and module name, whereas previously it was identified by its module name alone. This means that now a program can contain multiple modules with the same name, as long as they belong to different packages. This is a language change - the Haskell report says nothing about packages, but it is now necessary to understand packages in order to understand GHC's module system. For example, a type T from module M in package P is different from a type T from module M in package Q. Previously this wasn't an issue because there could only be a single module M in the program. The "module restriction" on combining packages has therefore been lifted, and a program can contain multiple versions of the same package. Note that none of the proposed syntax changes have yet been implemented, but the architecture is geared towards supporting import declarations qualified by package name, and that is probably the next step. It is now necessary to specify the package name when compiling a package, using the -package-name flag (which has been un-deprecated). Fortunately Cabal still uses -package-name. Certain packages are "wired in". Currently the wired-in packages are: base, haskell98, template-haskell and rts, and are always referred to by these versionless names. Other packages are referred to with full package IDs (eg. "network-1.0"). This is because the compiler needs to refer to entities in the wired-in packages, and we didn't want to bake the version of these packages into the comiler. It's conceivable that someone might want to upgrade the base package independently of GHC. Internal changes: - There are two module-related types: ModuleName just a FastString, the name of a module Module a pair of a PackageId and ModuleName A mapping from ModuleName can be a UniqFM, but a mapping from Module must be a FiniteMap (we provide it as ModuleEnv). - The "HomeModules" type that was passed around the compiler is now gone, replaced in most cases by the current package name which is contained in DynFlags. We can tell whether a Module comes from the current package by comparing its package name against the current package. - While I was here, I changed PrintUnqual to be a little more useful: it now returns the ModuleName that the identifier should be qualified with according to the current scope, rather than its original module. Also, PrintUnqual tells whether to qualify module names with package names (currently unused). Docs to follow. --- diff --git a/compiler/Makefile b/compiler/Makefile index 56673df..4aa67ce 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -183,12 +183,16 @@ endif # ifneq "$(way)" "dll" ifneq "$(TARGETPLATFORM)" "i386-unknown-mingw32" -HS_PROG=$(odir)/ghc$(_way)-$(ProjectVersion) +GHC_PROG=$(odir)/ghc$(_way)-$(ProjectVersion) else -HS_PROG=$(odir)/ghc$(_way) +GHC_PROG=$(odir)/ghc$(_way) endif else -HS_PROG=$(odir)/ghc-$(ProjectVersion) +GHC_PROG=$(odir)/ghc-$(ProjectVersion) +endif + +ifneq "$(stage)" "2" +HS_PROG = $(GHC_PROG) endif # ----------------------------------------------------------------------------- @@ -679,10 +683,10 @@ SRC_LD_OPTS += -no-link-chk all :: $(odir)/ghc-inplace ghc-inplace -$(odir)/ghc-inplace : $(HS_PROG) +$(odir)/ghc-inplace : $(GHC_PROG) @$(RM) $@ echo '#!/bin/sh' >>$@ - echo exec $(GHC_COMPILER_DIR_ABS)/$(HS_PROG) '-B$(subst \,\\,$(FPTOOLS_TOP_ABS_PLATFORM))' '"$$@"' >>$@ + echo exec $(GHC_COMPILER_DIR_ABS)/$(GHC_PROG) '-B$(subst \,\\,$(FPTOOLS_TOP_ABS_PLATFORM))' '"$$@"' >>$@ chmod 755 $@ ghc-inplace : stage1/ghc-inplace @@ -704,9 +708,9 @@ CLEAN_FILES += $(odir)/ghc-inplace DESTDIR = $(INSTALL_LIBRARY_DIR_GHC) ifneq "$(HOSTPLATFORM)" "i386-unknown-mingw32" -INSTALL_LIBEXECS += $(HS_PROG) +INSTALL_LIBEXECS += $(GHC_PROG) else -INSTALL_PROGS += $(HS_PROG) +INSTALL_PROGS += $(GHC_PROG) endif # ---------------------------------------------------------------------------- @@ -787,6 +791,19 @@ HS_IFACES = $(addsuffix .$(way_)hi,$(basename $(HS_OBJS))) # Haddock can't handle recursive modules currently, so we disable it for now. NO_HADDOCK_DOCS = YES + +# Don't build the GHC binary as normal, because we need to link it +# against the GHC package. The GHC binary itself is built by +# compiling Main.o separately and linking it with -package ghc. This is +# done using a separate Makefile: + +all :: $(GHC_PROG) + +$(GHC_PROG) : libHS$(PACKAGE)$(_way).a main/Main.hs + $(MAKE) -f Makefile.ghcbin $(MFLAGS) HS_PROG=$(GHC_PROG) $@ + +docs runtests $(BOOT_TARGET) TAGS clean distclean mostlyclean maintainer-clean $(INSTALL_TARGET) $(INSTALL_DOCS_TARGET) html chm HxS ps dvi txt:: + $(MAKE) -f Makefile.ghcbin $(MFLAGS) $@ endif #----------------------------------------------------------------------------- diff --git a/compiler/Makefile.ghcbin b/compiler/Makefile.ghcbin new file mode 100644 index 0000000..626ec51 --- /dev/null +++ b/compiler/Makefile.ghcbin @@ -0,0 +1,30 @@ +# This Makefile builds the GHC binary for stage2. In stage2, the GHC binary +# is built as a single Main module that links to the GHC package. It +# is easier to do this with a separate Makefile, because we don't want most +# of the options normally dumped into SRC_HC_OPTS by the main GHC Makefile. +# In particular, we don't want the .hi files picked up along the home package +# search path when compiling Main, we need the compiler to find them in +# the GHC package. + +TOP = .. +include $(TOP)/mk/boilerplate.mk + +stage=2 + +HC=$(GHC_STAGE1) +SRC_HC_OPTS += -package ghc +SRC_HC_OPTS += -DGHCI -DBREAKPOINT +SRC_HC_OPTS += -Istage$(stage) +SRC_HC_OPTS += \ + -cpp -fglasgow-exts -fno-generics -Rghc-timing \ + -I. -IcodeGen -InativeGen -Iparser + +odir=stage$(stage) + +HS_SRCS = main/Main.hs +HS_OBJS = $(patsubst %, $(odir)/%, $(addsuffix .$(way_)o,$(basename $(HS_SRCS)))) +$(odir)/main/Main.o : libHSghc$(_way).a + +include $(TOP)/mk/target.mk + +-include .depend-$(stage) diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs index 0c84685..172f8b0 100644 --- a/compiler/basicTypes/MkId.lhs +++ b/compiler/basicTypes/MkId.lhs @@ -855,18 +855,18 @@ unsafeCoerceName = mkWiredInIdName gHC_PRIM FSLIT("unsafeCoerce#") unsafeCoerceI nullAddrName = mkWiredInIdName gHC_PRIM FSLIT("nullAddr#") nullAddrIdKey nullAddrId seqName = mkWiredInIdName gHC_PRIM FSLIT("seq") seqIdKey seqId realWorldName = mkWiredInIdName gHC_PRIM FSLIT("realWorld#") realWorldPrimIdKey realWorldPrimId -lazyIdName = mkWiredInIdName pREL_BASE FSLIT("lazy") lazyIdKey lazyId - -errorName = mkWiredInIdName pREL_ERR FSLIT("error") errorIdKey eRROR_ID -recSelErrorName = mkWiredInIdName pREL_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID -runtimeErrorName = mkWiredInIdName pREL_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID -irrefutPatErrorName = mkWiredInIdName pREL_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID -recConErrorName = mkWiredInIdName pREL_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID -patErrorName = mkWiredInIdName pREL_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID -noMethodBindingErrorName = mkWiredInIdName pREL_ERR FSLIT("noMethodBindingError") +lazyIdName = mkWiredInIdName gHC_BASE FSLIT("lazy") lazyIdKey lazyId + +errorName = mkWiredInIdName gHC_ERR FSLIT("error") errorIdKey eRROR_ID +recSelErrorName = mkWiredInIdName gHC_ERR FSLIT("recSelError") recSelErrorIdKey rEC_SEL_ERROR_ID +runtimeErrorName = mkWiredInIdName gHC_ERR FSLIT("runtimeError") runtimeErrorIdKey rUNTIME_ERROR_ID +irrefutPatErrorName = mkWiredInIdName gHC_ERR FSLIT("irrefutPatError") irrefutPatErrorIdKey iRREFUT_PAT_ERROR_ID +recConErrorName = mkWiredInIdName gHC_ERR FSLIT("recConError") recConErrorIdKey rEC_CON_ERROR_ID +patErrorName = mkWiredInIdName gHC_ERR FSLIT("patError") patErrorIdKey pAT_ERROR_ID +noMethodBindingErrorName = mkWiredInIdName gHC_ERR FSLIT("noMethodBindingError") noMethodBindingErrorIdKey nO_METHOD_BINDING_ERROR_ID nonExhaustiveGuardsErrorName - = mkWiredInIdName pREL_ERR FSLIT("nonExhaustiveGuardsError") + = mkWiredInIdName gHC_ERR FSLIT("nonExhaustiveGuardsError") nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID \end{code} diff --git a/compiler/basicTypes/Module.lhs b/compiler/basicTypes/Module.lhs index f9b00f1..720c51f 100644 --- a/compiler/basicTypes/Module.lhs +++ b/compiler/basicTypes/Module.lhs @@ -11,36 +11,49 @@ the keys. \begin{code} module Module ( - Module -- Abstract, instance of Eq, Ord, Outputable - , pprModule -- :: Module -> SDoc - - , ModLocation(..) - , addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn - - , moduleString -- :: Module -> String - , moduleFS -- :: Module -> FastString - - , mkModule -- :: String -> Module - , mkModuleFS -- :: FastString -> Module - - , ModuleEnv - , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C - , delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv - , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv - , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv - , extendModuleEnv_C, filterModuleEnv - - , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet - + -- * The ModuleName type + ModuleName, + pprModuleName, + moduleNameFS, + moduleNameString, + mkModuleName, + mkModuleNameFS, + + -- * The Module type + Module, + modulePackageId, moduleName, + pprModule, + mkModule, + + -- * The ModuleLocation type + ModLocation(..), + addBootSuffix, addBootSuffix_maybe, addBootSuffixLocn, + + -- * Module mappings + ModuleEnv, + elemModuleEnv, extendModuleEnv, extendModuleEnvList, + extendModuleEnvList_C, plusModuleEnv_C, + delModuleEnvList, delModuleEnv, plusModuleEnv, lookupModuleEnv, + lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv, + moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv, + extendModuleEnv_C, filterModuleEnv, + + -- * ModuleName mappings + ModuleNameEnv, + + -- * Sets of modules + ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, + elemModuleSet ) where #include "HsVersions.h" import Outputable import Unique ( Uniquable(..) ) +import FiniteMap import UniqFM -import UniqSet -import Binary +import PackageConfig ( PackageId, packageIdFS, mainPackageId ) import FastString +import Binary \end{code} %************************************************************************ @@ -105,49 +118,86 @@ addBootSuffixLocn locn %************************************************************************ \begin{code} -newtype Module = Module FastString - -- Haskell module names can include the quote character ', - -- so the module names have the z-encoding applied to them - -instance Binary Module where - put_ bh (Module m) = put_ bh m - get bh = do m <- get bh; return (Module m) +-- | A ModuleName is a simple string, eg. @Data.List@. +newtype ModuleName = ModuleName FastString -instance Uniquable Module where - getUnique (Module nm) = getUnique nm +instance Uniquable ModuleName where + getUnique (ModuleName nm) = getUnique nm -instance Eq Module where +instance Eq ModuleName where nm1 == nm2 = getUnique nm1 == getUnique nm2 -- Warning: gives an ordering relation based on the uniques of the -- FastStrings which are the (encoded) module names. This is _not_ -- a lexicographical ordering. -instance Ord Module where +instance Ord ModuleName where nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 -instance Outputable Module where - ppr = pprModule +instance Outputable ModuleName where + ppr = pprModuleName -pprModule :: Module -> SDoc -pprModule (Module nm) = +instance Binary ModuleName where + put_ bh (ModuleName fs) = put_ bh fs + get bh = do fs <- get bh; return (ModuleName fs) + +pprModuleName :: ModuleName -> SDoc +pprModuleName (ModuleName nm) = getPprStyle $ \ sty -> if codeStyle sty then ftext (zEncodeFS nm) else ftext nm -moduleFS :: Module -> FastString -moduleFS (Module mod) = mod +moduleNameFS :: ModuleName -> FastString +moduleNameFS (ModuleName mod) = mod -moduleString :: Module -> String -moduleString (Module mod) = unpackFS mod +moduleNameString :: ModuleName -> String +moduleNameString (ModuleName mod) = unpackFS mod --- used to be called mkSrcModule -mkModule :: String -> Module -mkModule s = Module (mkFastString s) +mkModuleName :: String -> ModuleName +mkModuleName s = ModuleName (mkFastString s) --- used to be called mkSrcModuleFS -mkModuleFS :: FastString -> Module -mkModuleFS s = Module s +mkModuleNameFS :: FastString -> ModuleName +mkModuleNameFS s = ModuleName s +\end{code} + +%************************************************************************ +%* * +\subsection{A fully qualified module} +%* * +%************************************************************************ + +\begin{code} +-- | A Module is a pair of a 'PackageId' and a 'ModuleName'. +data Module = Module { + modulePackageId :: !PackageId, -- pkg-1.0 + moduleName :: !ModuleName -- A.B.C + } + deriving (Eq, Ord) + +instance Outputable Module where + ppr = pprModule + +instance Binary Module where + put_ bh (Module p n) = put_ bh p >> put_ bh n + get bh = do p <- get bh; n <- get bh; return (Module p n) + +mkModule :: PackageId -> ModuleName -> Module +mkModule = Module + +pprModule :: Module -> SDoc +pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n + +pprPackagePrefix p mod = getPprStyle doc + where + doc sty + | codeStyle sty = + if p == mainPackageId + then empty -- never qualify the main package in code + else ftext (zEncodeFS (packageIdFS p)) <> char '_' + | Just pkg <- qualModule sty mod = ftext (packageIdFS pkg) <> char ':' + -- the PrintUnqualified tells us which modules have to + -- be qualified with package names + | otherwise = empty \end{code} %************************************************************************ @@ -157,7 +207,7 @@ mkModuleFS s = Module s %************************************************************************ \begin{code} -type ModuleEnv elt = UniqFM elt +type ModuleEnv elt = FiniteMap Module elt emptyModuleEnv :: ModuleEnv a mkModuleEnv :: [(Module, a)] -> ModuleEnv a @@ -166,6 +216,7 @@ extendModuleEnv :: ModuleEnv a -> Module -> a -> ModuleEnv a extendModuleEnv_C :: (a->a->a) -> ModuleEnv a -> Module -> a -> ModuleEnv a plusModuleEnv :: ModuleEnv a -> ModuleEnv a -> ModuleEnv a extendModuleEnvList :: ModuleEnv a -> [(Module, a)] -> ModuleEnv a +extendModuleEnvList_C :: (a->a->a) -> ModuleEnv a -> [(Module, a)] -> ModuleEnv a delModuleEnvList :: ModuleEnv a -> [Module] -> ModuleEnv a delModuleEnv :: ModuleEnv a -> Module -> ModuleEnv a @@ -180,37 +231,45 @@ elemModuleEnv :: Module -> ModuleEnv a -> Bool foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b filterModuleEnv :: (a -> Bool) -> ModuleEnv a -> ModuleEnv a -filterModuleEnv = filterUFM -elemModuleEnv = elemUFM -extendModuleEnv = addToUFM -extendModuleEnv_C = addToUFM_C -extendModuleEnvList = addListToUFM -plusModuleEnv_C = plusUFM_C -delModuleEnvList = delListFromUFM -delModuleEnv = delFromUFM -plusModuleEnv = plusUFM -lookupModuleEnv = lookupUFM -lookupWithDefaultModuleEnv = lookupWithDefaultUFM -mapModuleEnv = mapUFM -mkModuleEnv = listToUFM -emptyModuleEnv = emptyUFM -moduleEnvElts = eltsUFM -unitModuleEnv = unitUFM -isEmptyModuleEnv = isNullUFM -foldModuleEnv = foldUFM +filterModuleEnv f = filterFM (\_ v -> f v) +elemModuleEnv = elemFM +extendModuleEnv = addToFM +extendModuleEnv_C = addToFM_C +extendModuleEnvList = addListToFM +extendModuleEnvList_C = addListToFM_C +plusModuleEnv_C = plusFM_C +delModuleEnvList = delListFromFM +delModuleEnv = delFromFM +plusModuleEnv = plusFM +lookupModuleEnv = lookupFM +lookupWithDefaultModuleEnv = lookupWithDefaultFM +mapModuleEnv f = mapFM (\_ v -> f v) +mkModuleEnv = listToFM +emptyModuleEnv = emptyFM +moduleEnvElts = eltsFM +unitModuleEnv = unitFM +isEmptyModuleEnv = isEmptyFM +foldModuleEnv f = foldFM (\_ v -> f v) \end{code} \begin{code} -type ModuleSet = UniqSet Module +type ModuleSet = FiniteMap Module () mkModuleSet :: [Module] -> ModuleSet extendModuleSet :: ModuleSet -> Module -> ModuleSet emptyModuleSet :: ModuleSet moduleSetElts :: ModuleSet -> [Module] elemModuleSet :: Module -> ModuleSet -> Bool -emptyModuleSet = emptyUniqSet -mkModuleSet = mkUniqSet -extendModuleSet = addOneToUniqSet -moduleSetElts = uniqSetToList -elemModuleSet = elementOfUniqSet +emptyModuleSet = emptyFM +mkModuleSet ms = listToFM [(m,()) | m <- ms ] +extendModuleSet s m = addToFM s m () +moduleSetElts = keysFM +elemModuleSet = elemFM +\end{code} + +A ModuleName has a Unique, so we can build mappings of these using +UniqFM. + +\begin{code} +type ModuleNameEnv elt = UniqFM elt \end{code} diff --git a/compiler/basicTypes/Module.lhs-boot b/compiler/basicTypes/Module.lhs-boot index d75c032..37fa6a9 100644 --- a/compiler/basicTypes/Module.lhs-boot +++ b/compiler/basicTypes/Module.lhs-boot @@ -1,6 +1,10 @@ \begin{code} module Module where +import PackageConfig (PackageId) + data Module +data ModuleName +moduleName :: Module -> ModuleName +modulePackageId :: Module -> PackageId \end{code} - diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs index 1e1fb31..3684a70 100644 --- a/compiler/basicTypes/Name.lhs +++ b/compiler/basicTypes/Name.lhs @@ -38,7 +38,7 @@ module Name ( import {-# SOURCE #-} TypeRep( TyThing ) import OccName -- All of it -import Module ( Module, moduleFS ) +import Module ( Module ) import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc ) import Unique ( Unique, Uniquable(..), getKey, pprUnique ) import Maybes ( orElse, isJust ) @@ -56,7 +56,7 @@ import Outputable data Name = Name { n_sort :: NameSort, -- What sort of name it is n_occ :: !OccName, -- Its occurrence name - n_uniq :: Unique, + n_uniq :: {-# UNPACK #-} !Unique, n_loc :: !SrcLoc -- Definition site } @@ -308,7 +308,7 @@ instance Outputable Name where instance OutputableBndr Name where pprBndr _ name = pprName name -pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) +pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \ sty -> case sort of WiredIn mod _ _ builtin -> pprExternal sty uniq mod occ True builtin @@ -317,18 +317,19 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) Internal -> pprInternal sty uniq occ pprExternal sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr_z_module mod <> char '_' <> ppr_z_occ_name occ + | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? - | debugStyle sty = ppr mod <> dot <> ppr_occ_name occ - <> braces (hsep [if is_wired then ptext SLIT("(w)") else empty, - pprNameSpaceBrief (occNameSpace occ), - pprUnique uniq]) + | debugStyle sty = ppr mod <> dot <> ppr_occ_name occ + <> braces (hsep [if is_wired then ptext SLIT("(w)") else empty, + pprNameSpaceBrief (occNameSpace occ), + pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- never qualify builtin syntax - | unqualStyle sty mod occ = ppr_occ_name occ - | otherwise = ppr mod <> dot <> ppr_occ_name occ + | Just mod <- qualName sty mod occ = ppr mod <> dot <> ppr_occ_name occ + -- the PrintUnqualified tells us how to qualify this Name, if at all + | otherwise = ppr_occ_name occ pprInternal sty uniq occ | codeStyle sty = pprUnique uniq @@ -356,8 +357,6 @@ ppr_occ_name occ = ftext (occNameFS occ) -- In code style, we Z-encode the strings. The results of Z-encoding each FastString are -- cached behind the scenes in the FastString implementation. ppr_z_occ_name occ = ftext (zEncodeFS (occNameFS occ)) -ppr_z_module mod = ftext (zEncodeFS (moduleFS mod)) - \end{code} %************************************************************************ diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs index 7965449..3c6cd77 100644 --- a/compiler/basicTypes/RdrName.lhs +++ b/compiler/basicTypes/RdrName.lhs @@ -15,8 +15,8 @@ module RdrName ( mkDerivedRdrName, -- Destruction - rdrNameModule, rdrNameOcc, setRdrNameSpace, - isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isUnqual, + rdrNameOcc, setRdrNameSpace, + isRdrDataCon, isRdrTyVar, isRdrTc, isQual, isQual_maybe, isUnqual, isOrig, isOrig_maybe, isExact, isExact_maybe, isSrcRdrName, -- Printing; instance Outputable RdrName @@ -41,7 +41,7 @@ module RdrName ( #include "HsVersions.h" import OccName -import Module ( Module, mkModuleFS ) +import Module ( ModuleName, mkModuleNameFS, Module, moduleName ) import Name ( Name, NamedThing(getName), nameModule, nameParent_maybe, nameOccName, isExternalName, nameSrcLoc ) import Maybes ( mapCatMaybes ) @@ -62,7 +62,7 @@ data RdrName = Unqual OccName -- Used for ordinary, unqualified occurrences - | Qual Module OccName + | Qual ModuleName OccName -- A qualified name written by the user in -- *source* code. The module isn't necessarily -- the module where the thing is defined; @@ -92,12 +92,6 @@ data RdrName %************************************************************************ \begin{code} -rdrNameModule :: RdrName -> Module -rdrNameModule (Qual m _) = m -rdrNameModule (Orig m _) = m -rdrNameModule (Exact n) = nameModule n -rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n) - rdrNameOcc :: RdrName -> OccName rdrNameOcc (Qual _ occ) = occ rdrNameOcc (Unqual occ) = occ @@ -125,7 +119,7 @@ setRdrNameSpace (Exact n) ns = Orig (nameModule n) mkRdrUnqual :: OccName -> RdrName mkRdrUnqual occ = Unqual occ -mkRdrQual :: Module -> OccName -> RdrName +mkRdrQual :: ModuleName -> OccName -> RdrName mkRdrQual mod occ = Qual mod occ mkOrig :: Module -> OccName -> RdrName @@ -146,7 +140,7 @@ mkVarUnqual :: FastString -> RdrName mkVarUnqual n = Unqual (mkVarOccFS n) mkQual :: NameSpace -> (FastString, FastString) -> RdrName -mkQual sp (m, n) = Qual (mkModuleFS m) (mkOccNameFS sp n) +mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccNameFS sp n) getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) @@ -178,6 +172,9 @@ isUnqual other = False isQual (Qual _ _) = True isQual _ = False +isQual_maybe (Qual m n) = Just (m,n) +isQual_maybe _ = Nothing + isOrig (Orig _ _) = True isOrig _ = False @@ -372,24 +369,31 @@ pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] pickGREs rdr_name gres = mapCatMaybes pick gres where - is_unqual = isUnqual rdr_name - mod = rdrNameModule rdr_name + rdr_is_unqual = isUnqual rdr_name + rdr_is_qual = isQual_maybe rdr_name pick :: GlobalRdrElt -> Maybe GlobalRdrElt pick gre@(GRE {gre_prov = LocalDef, gre_name = n}) -- Local def - | is_unqual || nameModule n == mod = Just gre - | otherwise = Nothing + | rdr_is_unqual = Just gre + | Just (mod,_) <- rdr_is_qual, + mod == moduleName (nameModule n) = Just gre + | otherwise = Nothing pick gre@(GRE {gre_prov = Imported [is]}) -- Single import (efficiency) - | is_unqual = if not (is_qual (is_decl is)) then Just gre - else Nothing - | otherwise = if mod == is_as (is_decl is) then Just gre - else Nothing + | rdr_is_unqual, + not (is_qual (is_decl is)) = Just gre + | Just (mod,_) <- rdr_is_qual, + mod == is_as (is_decl is) = Just gre + | otherwise = Nothing pick gre@(GRE {gre_prov = Imported is}) -- Multiple import | null filtered_is = Nothing | otherwise = Just (gre {gre_prov = Imported filtered_is}) where - filtered_is | is_unqual = filter (not . is_qual . is_decl) is - | otherwise = filter ((== mod) . is_as . is_decl) is + filtered_is | rdr_is_unqual + = filter (not . is_qual . is_decl) is + | Just (mod,_) <- rdr_is_qual + = filter ((== mod) . is_as . is_decl) is + | otherwise + = [] isLocalGRE :: GlobalRdrElt -> Bool isLocalGRE (GRE {gre_prov = LocalDef}) = True @@ -449,10 +453,12 @@ data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, data ImpDeclSpec -- Describes a particular import declaration -- Shared among all the Provenaces for that decl = ImpDeclSpec { - is_mod :: Module, -- 'import Muggle' + is_mod :: ModuleName, -- 'import Muggle' -- Note the Muggle may well not be -- the defining module for this thing! - is_as :: Module, -- 'as M' (or 'Muggle' if there is no 'as' clause) + -- TODO: either should be Module, or there + -- should be a Maybe PackageId here too. + is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause) is_qual :: Bool, -- True <=> qualified (only) is_dloc :: SrcSpan -- Location of import declaration } @@ -476,7 +482,7 @@ importSpecLoc :: ImportSpec -> SrcSpan importSpecLoc (ImpSpec decl ImpAll) = is_dloc decl importSpecLoc (ImpSpec _ item) = is_iloc item -importSpecModule :: ImportSpec -> Module +importSpecModule :: ImportSpec -> ModuleName importSpecModule is = is_mod (is_decl is) -- Note [Comparing provenance] diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index 5c83281..aacac3e 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -103,11 +103,11 @@ module CLabel ( #include "HsVersions.h" -import Packages ( HomeModules ) import StaticFlags ( opt_Static, opt_DoTickyProfiling ) -import Packages ( isHomeModule, isDllName ) +import Packages ( isDllName ) import DataCon ( ConTag ) -import Module ( Module ) +import PackageConfig ( PackageId ) +import Module ( Module, modulePackageId ) import Name ( Name, isExternalName ) import Unique ( pprUnique, Unique ) import PrimOp ( PrimOp ) @@ -293,20 +293,20 @@ mkLocalInfoTableLabel name = IdLabel name InfoTable mkLocalEntryLabel name = IdLabel name Entry mkLocalClosureTableLabel name = IdLabel name ClosureTable -mkClosureLabel hmods name - | isDllName hmods name = DynIdLabel name Closure +mkClosureLabel this_pkg name + | isDllName this_pkg name = DynIdLabel name Closure | otherwise = IdLabel name Closure -mkInfoTableLabel hmods name - | isDllName hmods name = DynIdLabel name InfoTable +mkInfoTableLabel this_pkg name + | isDllName this_pkg name = DynIdLabel name InfoTable | otherwise = IdLabel name InfoTable -mkEntryLabel hmods name - | isDllName hmods name = DynIdLabel name Entry +mkEntryLabel this_pkg name + | isDllName this_pkg name = DynIdLabel name Entry | otherwise = IdLabel name Entry -mkClosureTableLabel hmods name - | isDllName hmods name = DynIdLabel name ClosureTable +mkClosureTableLabel this_pkg name + | isDllName this_pkg name = DynIdLabel name ClosureTable | otherwise = IdLabel name ClosureTable mkLocalConInfoTableLabel con = IdLabel con ConInfoTable @@ -320,12 +320,12 @@ mkConInfoTableLabel name True = DynIdLabel name ConInfoTable mkStaticInfoTableLabel name False = IdLabel name StaticInfoTable mkStaticInfoTableLabel name True = DynIdLabel name StaticInfoTable -mkConEntryLabel hmods name - | isDllName hmods name = DynIdLabel name ConEntry +mkConEntryLabel this_pkg name + | isDllName this_pkg name = DynIdLabel name ConEntry | otherwise = IdLabel name ConEntry -mkStaticConEntryLabel hmods name - | isDllName hmods name = DynIdLabel name StaticConEntry +mkStaticConEntryLabel this_pkg name + | isDllName this_pkg name = DynIdLabel name StaticConEntry | otherwise = IdLabel name StaticConEntry @@ -337,13 +337,13 @@ mkDefaultLabel uniq = CaseLabel uniq CaseDefault mkStringLitLabel = StringLitLabel mkAsmTempLabel = AsmTempLabel -mkModuleInitLabel :: HomeModules -> Module -> String -> CLabel -mkModuleInitLabel hmods mod way - = ModuleInitLabel mod way $! (not (isHomeModule hmods mod)) +mkModuleInitLabel :: PackageId -> Module -> String -> CLabel +mkModuleInitLabel this_pkg mod way + = ModuleInitLabel mod way $! modulePackageId mod /= this_pkg -mkPlainModuleInitLabel :: HomeModules -> Module -> CLabel -mkPlainModuleInitLabel hmods mod - = PlainModuleInitLabel mod $! (not (isHomeModule hmods mod)) +mkPlainModuleInitLabel :: PackageId -> Module -> CLabel +mkPlainModuleInitLabel this_pkg mod + = PlainModuleInitLabel mod $! modulePackageId mod /= this_pkg -- Some fixed runtime system labels diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 5908314..a1cbbf5 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -38,7 +38,6 @@ import Unique import UniqFM import SrcLoc import DynFlags ( DynFlags, DynFlag(..) ) -import Packages ( HomeModules ) import StaticFlags ( opt_SccProfilingOn ) import ErrUtils ( printError, dumpIfSet_dyn, showPass ) import StringBuffer ( hGetStringBuffer ) @@ -907,8 +906,8 @@ initEnv = listToUFM [ Var (CmmLit (CmmInt (fromIntegral stdInfoTableSizeB) wordRep) )) ] -parseCmmFile :: DynFlags -> HomeModules -> FilePath -> IO (Maybe Cmm) -parseCmmFile dflags hmods filename = do +parseCmmFile :: DynFlags -> FilePath -> IO (Maybe Cmm) +parseCmmFile dflags filename = do showPass dflags "ParseCmm" buf <- hGetStringBuffer filename let @@ -919,7 +918,7 @@ parseCmmFile dflags hmods filename = do case unP cmmParse init_state of PFailed span err -> do printError span err; return Nothing POk _ code -> do - cmm <- initC dflags hmods no_module (getCmm (unEC code initEnv [] >> return ())) + cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ())) dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm]) return (Just cmm) where diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index f78edda..96735ef 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -240,8 +240,8 @@ getCgIdInfo id name = idName id in if isExternalName name then do - hmods <- getHomeModules - let ext_lbl = CmmLit (CmmLabel (mkClosureLabel hmods name)) + this_pkg <- getThisPackage + let ext_lbl = CmmLit (CmmLabel (mkClosureLabel this_pkg name)) return (stableIdInfo id ext_lbl (mkLFImported id)) else if isVoidArg (idCgRep id) then diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index e7c0894..7b4861a 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -336,10 +336,10 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts -- Bind the default binder if necessary -- (avoiding it avoids the assignment) -- The deadness info is set by StgVarInfo - ; hmods <- getHomeModules + ; this_pkg <- getThisPackage ; whenC (not (isDeadBinder bndr)) (do { tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign tmp_reg (tagToClosure hmods tycon tag_amode)) }) + ; stmtC (CmmAssign tmp_reg (tagToClosure this_pkg tycon tag_amode)) }) -- Compile the alts ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 0d8d731..115439a 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -70,10 +70,10 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> FCode (Id, CgIdInfo) cgTopRhsCon id con args = do { - ; hmods <- getHomeModules + ; this_pkg <- getThisPackage #if mingw32_TARGET_OS -- Windows DLLs have a problem with static cross-DLL refs. - ; ASSERT( not (isDllConApp hmods con args) ) return () + ; ASSERT( not (isDllConApp this_pkg con args) ) return () #endif ; ASSERT( args `lengthIs` dataConRepArity con ) return () @@ -83,9 +83,9 @@ cgTopRhsCon id con args ; let name = idName id lf_info = mkConLFInfo con - closure_label = mkClosureLabel hmods name + closure_label = mkClosureLabel this_pkg name caffy = any stgArgHasCafRefs args - (closure_info, amodes_w_offsets) = layOutStaticConstr hmods con amodes + (closure_info, amodes_w_offsets) = layOutStaticConstr this_pkg con amodes closure_rep = mkStaticClosureFields closure_info dontCareCCS -- Because it's static data @@ -142,9 +142,9 @@ at all. \begin{code} buildDynCon binder cc con [] - = do hmods <- getHomeModules + = do this_pkg <- getThisPackage returnFC (stableIdInfo binder - (mkLblExpr (mkClosureLabel hmods (dataConName con))) + (mkLblExpr (mkClosureLabel this_pkg (dataConName con))) (mkConLFInfo con)) \end{code} @@ -198,9 +198,9 @@ Now the general case. \begin{code} buildDynCon binder ccs con args = do { - ; hmods <- getHomeModules + ; this_pkg <- getThisPackage ; let - (closure_info, amodes_w_offsets) = layOutDynConstr hmods con args + (closure_info, amodes_w_offsets) = layOutDynConstr this_pkg con args ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets ; returnFC (heapIdInfo binder hp_off lf_info) } @@ -230,10 +230,10 @@ found a $con$. \begin{code} bindConArgs :: DataCon -> [Id] -> Code bindConArgs con args - = do hmods <- getHomeModules + = do this_pkg <- getThisPackage let bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg) - (_, args_w_offsets) = layOutDynConstr hmods con (addIdReps args) + (_, args_w_offsets) = layOutDynConstr this_pkg con (addIdReps args) -- ASSERT(not (isUnboxedTupleCon con)) return () mapCs bind_arg args_w_offsets @@ -416,7 +416,7 @@ static closure, for a constructor. cgDataCon :: DataCon -> Code cgDataCon data_con = do { -- Don't need any dynamic closure code for zero-arity constructors - hmods <- getHomeModules + this_pkg <- getThisPackage ; let -- To allow the debuggers, interpreters, etc to cope with @@ -424,10 +424,10 @@ cgDataCon data_con -- time), we take care that info-table contains the -- information we need. (static_cl_info, _) = - layOutStaticConstr hmods data_con arg_reps + layOutStaticConstr this_pkg data_con arg_reps (dyn_cl_info, arg_things) = - layOutDynConstr hmods data_con arg_reps + layOutDynConstr this_pkg data_con arg_reps emit_info cl_info ticky_code = do { code_blks <- getCgStmts the_code diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 33d72f1..e36b2ae 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -152,8 +152,8 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) do { (_,amode) <- getArgAmode arg ; amode' <- assignTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial - ; hmods <- getHomeModules - ; stmtC (CmmAssign nodeReg (tagToClosure hmods tycon amode')) + ; this_pkg <- getThisPackage + ; stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon amode')) ; performReturn (emitAlgReturnCode tycon amode') } where -- If you're reading this code in the attempt to figure @@ -185,9 +185,9 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon -- c.f. cgExpr (...TagToEnumOp...) = do tag_reg <- newTemp wordRep - hmods <- getHomeModules + this_pkg <- getThisPackage cgPrimOp [tag_reg] primop args emptyVarSet - stmtC (CmmAssign nodeReg (tagToClosure hmods tycon (CmmReg tag_reg))) + stmtC (CmmAssign nodeReg (tagToClosure this_pkg tycon (CmmReg tag_reg))) performReturn (emitAlgReturnCode tycon (CmmReg tag_reg)) where result_info = getPrimOpResultInfo primop @@ -282,8 +282,8 @@ cgRhs name (StgRhsCon maybe_cc con args) ; returnFC (name, idinfo) } cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = do hmods <- getHomeModules - mkRhsClosure hmods name cc bi srt fvs upd_flag args body + = do this_pkg <- getThisPackage + mkRhsClosure this_pkg name cc bi srt fvs upd_flag args body \end{code} mkRhsClosure looks for two special forms of the right-hand side: @@ -306,7 +306,7 @@ form: \begin{code} -mkRhsClosure hmods bndr cc bi srt +mkRhsClosure this_pkg bndr cc bi srt [the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -328,7 +328,7 @@ mkRhsClosure hmods bndr cc bi srt where lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr hmods con (addIdReps params) + (_, params_w_offsets) = layOutDynConstr this_pkg con (addIdReps params) -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset @@ -352,7 +352,7 @@ We only generate an Ap thunk if all the free variables are pointers, for semi-obvious reasons. \begin{code} -mkRhsClosure hmods bndr cc bi srt +mkRhsClosure this_pkg bndr cc bi srt fvs upd_flag [] -- No args; a thunk @@ -377,7 +377,7 @@ mkRhsClosure hmods bndr cc bi srt The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure hmods bndr cc bi srt fvs upd_flag args body +mkRhsClosure this_pkg bndr cc bi srt fvs upd_flag args body = cgRhsClosure bndr cc bi srt fvs upd_flag args body \end{code} diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index 10f41bd..e66e1b8 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -23,8 +23,7 @@ import StgSyn ( StgLiveVars, StgArg, stgArgType ) import CgProf ( curCCS, curCCSAddr ) import CgBindery ( getVolatileRegs, getArgAmodes ) import CgMonad -import CgUtils ( cmmOffsetW, cmmOffsetB, cmmLoadIndexW, newTemp, - assignTemp ) +import CgUtils ( cmmOffsetW, cmmOffsetB, newTemp ) import Type ( tyConAppTyCon, repType ) import TysPrim import CLabel ( mkForeignLabel, mkRtsCodeLabel ) diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 184af90..ae6c892 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -53,7 +53,7 @@ import TyCon ( tyConPrimRep ) import CostCentre ( CostCentreStack ) import Util ( mapAccumL, filterOut ) import Constants ( wORD_SIZE ) -import Packages ( HomeModules ) +import PackageConfig ( PackageId ) import Outputable \end{code} @@ -123,7 +123,7 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: HomeModules + :: PackageId -> DataCon -> [(CgRep,a)] -> (ClosureInfo, @@ -132,8 +132,8 @@ layOutDynConstr, layOutStaticConstr layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True -layOutConstr is_static hmods data_con args - = (mkConInfo hmods is_static data_con tot_wds ptr_wds, +layOutConstr is_static this_pkg data_con args + = (mkConInfo this_pkg is_static data_con tot_wds ptr_wds, things_w_offsets) where (tot_wds, -- #ptr_wds + #nonptr_wds diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 22462e7..1866df4 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -47,7 +47,7 @@ module CgMonad ( Sequel(..), -- ToDo: unabstract? -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getInfoDown, getDynFlags, getHomeModules, + getState, setState, getInfoDown, getDynFlags, getThisPackage, -- more localised access to monad state getStkUsage, setStkUsage, @@ -61,8 +61,8 @@ module CgMonad ( import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) -import DynFlags ( DynFlags ) -import Packages ( HomeModules ) +import DynFlags ( DynFlags(..) ) +import PackageConfig ( PackageId ) import Cmm import CmmUtils ( CmmStmts, isNopStmt ) import CLabel @@ -97,7 +97,6 @@ along. data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { cgd_dflags :: DynFlags, - cgd_hmods :: HomeModules, -- Packages we depend on cgd_mod :: Module, -- Module being compiled cgd_statics :: CgBindings, -- [Id -> info] : static environment cgd_srt :: CLabel, -- label of the current SRT @@ -105,10 +104,9 @@ data CgInfoDownwards -- information only passed *downwards* by the monad cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block: } -initCgInfoDown :: DynFlags -> HomeModules -> Module -> CgInfoDownwards -initCgInfoDown dflags hmods mod +initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards +initCgInfoDown dflags mod = MkCgInfoDown { cgd_dflags = dflags, - cgd_hmods = hmods, cgd_mod = mod, cgd_statics = emptyVarEnv, cgd_srt = error "initC: srt", @@ -378,11 +376,11 @@ instance Monad FCode where The Abstract~C is not in the environment so as to improve strictness. \begin{code} -initC :: DynFlags -> HomeModules -> Module -> FCode a -> IO a +initC :: DynFlags -> Module -> FCode a -> IO a -initC dflags hmods mod (FCode code) +initC dflags mod (FCode code) = do { uniqs <- mkSplitUniqSupply 'c' - ; case code (initCgInfoDown dflags hmods mod) (initCgState uniqs) of + ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of (res, _) -> return res } @@ -510,8 +508,8 @@ getInfoDown = FCode $ \info_down state -> (info_down,state) getDynFlags :: FCode DynFlags getDynFlags = liftM cgd_dflags getInfoDown -getHomeModules :: FCode HomeModules -getHomeModules = liftM cgd_hmods getInfoDown +getThisPackage :: FCode PackageId +getThisPackage = liftM thisPackage getDynFlags withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index eee1083..9bbf05b 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -292,7 +292,7 @@ emitCostCentreDecl -> Code emitCostCentreDecl cc = do { label <- mkStringCLit (costCentreUserName cc) - ; modl <- mkStringCLit (moduleString (cc_mod cc)) + ; modl <- mkStringCLit (showSDoc (pprModule (cc_mod cc))) ; let lits = [ zero, -- StgInt ccID, label, -- char *label, diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index dd7327b..56614a8 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -118,9 +118,9 @@ performTailCall fun_info arg_amodes pending_assts opt_node_asst | nodeMustPointToIt lf_info = node_asst | otherwise = noStmts ; EndOfBlockInfo sp _ <- getEndOfBlockInfo - ; hmods <- getHomeModules + ; this_pkg <- getThisPackage - ; case (getCallMethod hmods fun_name lf_info (length arg_amodes)) of + ; case (getCallMethod this_pkg fun_name lf_info (length arg_amodes)) of -- Node must always point to things we enter EnterIt -> do diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 2f69927..21e6d08 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -48,13 +48,12 @@ import MachOp ( MachRep(..), wordRep, MachOp(..), MachHint(..), mo_wordULt, mo_wordUGt, mo_wordUGe, machRepByteWidth ) import ForeignCall ( CCallConv(..) ) import Literal ( Literal(..) ) -import CLabel ( CLabel, mkStringLitLabel ) import Digraph ( SCC(..), stronglyConnComp ) import ListSetOps ( assocDefault ) import Util ( filterOut, sortLe ) import DynFlags ( DynFlags(..), HscTarget(..) ) -import Packages ( HomeModules ) -import FastString ( LitString, FastString, bytesFS ) +import FastString ( LitString, bytesFS ) +import PackageConfig ( PackageId ) import Outputable import Char ( ord ) @@ -213,11 +212,11 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -tagToClosure :: HomeModules -> TyCon -> CmmExpr -> CmmExpr -tagToClosure hmods tycon tag +tagToClosure :: PackageId -> TyCon -> CmmExpr -> CmmExpr +tagToClosure this_pkg tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep where closure_tbl = CmmLit (CmmLabel lbl) - lbl = mkClosureTableLabel hmods (tyConName tycon) + lbl = mkClosureTableLabel this_pkg (tyConName tycon) ------------------------------------------------------------------------- -- @@ -488,7 +487,6 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C -- a 2-branch switch always turns into an if. small = n_tags <= 4 dense = n_branches > (n_tags `div` 2) - exhaustive = n_tags == n_branches n_branches = length branches -- ignore default slots at each end of the range if there's diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs index 84d9dd9..d137d4d 100644 --- a/compiler/codeGen/ClosureInfo.lhs +++ b/compiler/codeGen/ClosureInfo.lhs @@ -61,8 +61,8 @@ import SMRep -- all of it import CLabel -import Constants ( mIN_PAYLOAD_SIZE ) -import Packages ( isDllName, HomeModules ) +import Packages ( isDllName ) +import PackageConfig ( PackageId ) import StaticFlags ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling ) import Id ( Id, idType, idArity, idName ) @@ -330,15 +330,15 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds -mkConInfo :: HomeModules +mkConInfo :: PackageId -> Bool -- Is static -> DataCon -> Int -> Int -- Total and pointer words -> ClosureInfo -mkConInfo hmods is_static data_con tot_wds ptr_wds +mkConInfo this_pkg is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, closureCon = data_con, - closureDllCon = isDllName hmods (dataConName data_con) } + closureDllCon = isDllName this_pkg (dataConName data_con) } where sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds \end{code} @@ -560,30 +560,30 @@ data CallMethod CLabel -- The code label Int -- Its arity -getCallMethod :: HomeModules +getCallMethod :: PackageId -> Name -- Function being applied -> LambdaFormInfo -- Its info -> Int -- Number of available arguments -> CallMethod -getCallMethod hmods name lf_info n_args +getCallMethod this_pkg name lf_info n_args | nodeMustPointToIt lf_info && opt_Parallel = -- If we're parallel, then we must always enter via node. -- The reason is that the closure may have been -- fetched since we allocated it. EnterIt -getCallMethod hmods name (LFReEntrant _ arity _ _) n_args +getCallMethod this_pkg name (LFReEntrant _ arity _ _) n_args | n_args == 0 = ASSERT( arity /= 0 ) ReturnIt -- No args at all | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel hmods name) arity + | otherwise = DirectEntry (enterIdLabel this_pkg name) arity -getCallMethod hmods name (LFCon con) n_args +getCallMethod this_pkg name (LFCon con) n_args = ASSERT( n_args == 0 ) ReturnCon con -getCallMethod hmods name (LFThunk _ _ updatable std_form_info is_fun) n_args +getCallMethod this_pkg name (LFThunk _ _ updatable std_form_info is_fun) n_args | is_fun -- Must always "call" a function-typed = SlowCall -- thing, cannot just enter it [in eval/apply, the entry code -- is the fast-entry code] @@ -598,24 +598,24 @@ getCallMethod hmods name (LFThunk _ _ updatable std_form_info is_fun) n_args | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) - JumpToIt (thunkEntryLabel hmods name std_form_info updatable) + JumpToIt (thunkEntryLabel this_pkg name std_form_info updatable) -getCallMethod hmods name (LFUnknown True) n_args +getCallMethod this_pkg name (LFUnknown True) n_args = SlowCall -- might be a function -getCallMethod hmods name (LFUnknown False) n_args +getCallMethod this_pkg name (LFUnknown False) n_args = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod hmods name (LFBlackHole _) n_args +getCallMethod this_pkg name (LFBlackHole _) n_args = SlowCall -- Presumably the black hole has by now -- been updated, but we don't know with -- what, so we slow call it -getCallMethod hmods name (LFLetNoEscape 0) n_args +getCallMethod this_pkg name (LFLetNoEscape 0) n_args = JumpToIt (enterReturnPtLabel (nameUnique name)) -getCallMethod hmods name (LFLetNoEscape arity) n_args +getCallMethod this_pkg name (LFLetNoEscape arity) n_args | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) @@ -845,12 +845,12 @@ closureLabelFromCI _ = panic "closureLabelFromCI" -- thunkEntryLabel is a local help function, not exported. It's used from both -- entryLabelFromCI and getCallMethod. -thunkEntryLabel hmods thunk_id (ApThunk arity) is_updatable +thunkEntryLabel this_pkg thunk_id (ApThunk arity) is_updatable = enterApLabel is_updatable arity -thunkEntryLabel hmods thunk_id (SelectorThunk offset) upd_flag +thunkEntryLabel this_pkg thunk_id (SelectorThunk offset) upd_flag = enterSelectorLabel upd_flag offset -thunkEntryLabel hmods thunk_id _ is_updatable - = enterIdLabel hmods thunk_id +thunkEntryLabel this_pkg thunk_id _ is_updatable + = enterIdLabel this_pkg thunk_id enterApLabel is_updatable arity | tablesNextToCode = mkApInfoTableLabel is_updatable arity @@ -860,9 +860,9 @@ enterSelectorLabel upd_flag offset | tablesNextToCode = mkSelectorInfoLabel upd_flag offset | otherwise = mkSelectorEntryLabel upd_flag offset -enterIdLabel hmods id - | tablesNextToCode = mkInfoTableLabel hmods id - | otherwise = mkEntryLabel hmods id +enterIdLabel this_pkg id + | tablesNextToCode = mkInfoTableLabel this_pkg id + | otherwise = mkEntryLabel this_pkg id enterLocalIdLabel id | tablesNextToCode = mkLocalInfoTableLabel id diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 48c0cbf..0422a87 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -38,11 +38,11 @@ import PprCmm ( pprCmms ) import MachOp ( wordRep ) import StgSyn -import PrelNames ( gHC_PRIM, rOOT_MAIN, pREL_TOP_HANDLER ) -import Packages ( HomeModules ) +import PrelNames ( gHC_PRIM, rOOT_MAIN, gHC_TOP_HANDLER ) import DynFlags ( DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_SccProfilingOn ) +import PackageConfig ( PackageId ) import HscTypes ( ForeignStubs(..) ) import CostCentre ( CollectedCCs ) import Id ( Id, idName, setIdName ) @@ -51,16 +51,14 @@ import OccName ( mkLocalOcc ) import TyCon ( TyCon ) import Module ( Module ) import ErrUtils ( dumpIfSet_dyn, showPass ) -import Panic ( assertPanic ) #ifdef DEBUG -import Outputable +import Panic ( assertPanic ) #endif \end{code} \begin{code} codeGen :: DynFlags - -> HomeModules -> Module -> [TyCon] -> ForeignStubs @@ -69,7 +67,7 @@ codeGen :: DynFlags -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> IO [Cmm] -- Output -codeGen dflags hmods this_mod data_tycons foreign_stubs imported_mods +codeGen dflags this_mod data_tycons foreign_stubs imported_mods cost_centre_info stg_binds = do { showPass dflags "CodeGen" @@ -79,10 +77,10 @@ codeGen dflags hmods this_mod data_tycons foreign_stubs imported_mods -- Why? -- ; mapM_ (\x -> seq x (return ())) data_tycons - ; code_stuff <- initC dflags hmods this_mod $ do - { cmm_binds <- mapM (getCmm . cgTopBinding dflags hmods) stg_binds + ; code_stuff <- initC dflags this_mod $ do + { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons - ; cmm_init <- getCmm (mkModuleInit dflags hmods way cost_centre_info + ; cmm_init <- getCmm (mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods) ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) @@ -143,7 +141,6 @@ We initialise the module tree by keeping a work-stack, \begin{code} mkModuleInit :: DynFlags - -> HomeModules -> String -- the "way" -> CollectedCCs -- cost centre info -> Module @@ -151,7 +148,7 @@ mkModuleInit -> ForeignStubs -> [Module] -> Code -mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs imported_mods +mkModuleInit dflags way cost_centre_info this_mod main_mod foreign_stubs imported_mods = do { if opt_SccProfilingOn then do { -- Allocate the static boolean that records if this @@ -184,9 +181,11 @@ mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs i (emitSimpleProc plain_main_init_lbl jump_to_init) } where - plain_init_lbl = mkPlainModuleInitLabel hmods this_mod - real_init_lbl = mkModuleInitLabel hmods this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel hmods rOOT_MAIN + this_pkg = thisPackage dflags + + plain_init_lbl = mkPlainModuleInitLabel this_pkg this_mod + real_init_lbl = mkModuleInitLabel this_pkg this_mod way + plain_main_init_lbl = mkPlainModuleInitLabel this_pkg rOOT_MAIN jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) @@ -195,7 +194,7 @@ mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs i -- Main refers to GHC.TopHandler.runIO, so make sure we call the -- init function for GHC.TopHandler. extra_imported_mods - | this_mod == main_mod = [pREL_TOP_HANDLER] + | this_mod == main_mod = [gHC_TOP_HANDLER] | otherwise = [] mod_init_code = do @@ -204,7 +203,7 @@ mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs i -- Now do local stuff ; initCostCentres cost_centre_info - ; mapCs (registerModuleImport hmods way) + ; mapCs (registerModuleImport this_pkg way) (imported_mods++extra_imported_mods) } @@ -214,13 +213,13 @@ mkModuleInit dflags hmods way cost_centre_info this_mod main_mod foreign_stubs i , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) wordRep) [] ] ----------------------- -registerModuleImport :: HomeModules -> String -> Module -> Code -registerModuleImport hmods way mod +registerModuleImport :: PackageId -> String -> Module -> Code +registerModuleImport this_pkg way mod | mod == gHC_PRIM = nopC | otherwise -- Push the init procedure onto the work stack = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1)) - , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel hmods mod way)) ] + , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel this_pkg mod way)) ] \end{code} @@ -261,32 +260,32 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBinding :: DynFlags -> HomeModules -> (StgBinding,[(Id,[Id])]) -> Code -cgTopBinding dflags hmods (StgNonRec id rhs, srts) +cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code +cgTopBinding dflags (StgNonRec id rhs, srts) = do { id' <- maybeExternaliseId dflags id - ; mapM_ (mkSRT hmods [id']) srts + ; mapM_ (mkSRT (thisPackage dflags) [id']) srts ; (id,info) <- cgTopRhs id' rhs ; addBindC id info -- Add the *un-externalised* Id to the envt, -- so we find it when we look up occurrences } -cgTopBinding dflags hmods (StgRec pairs, srts) +cgTopBinding dflags (StgRec pairs, srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - ; mapM_ (mkSRT hmods bndrs') srts + ; mapM_ (mkSRT (thisPackage dflags) bndrs') srts ; _new_binds <- fixC (\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; nopC } -mkSRT :: HomeModules -> [Id] -> (Id,[Id]) -> Code -mkSRT hmods these (id,[]) = nopC -mkSRT hmods these (id,ids) +mkSRT :: PackageId -> [Id] -> (Id,[Id]) -> Code +mkSRT this_pkg these (id,[]) = nopC +mkSRT this_pkg these (id,ids) = do { ids <- mapFCs remap ids ; id <- remap id ; emitRODataLits (mkSRTLabel (idName id)) - (map (CmmLabel . mkClosureLabel hmods . idName) ids) + (map (CmmLabel . mkClosureLabel this_pkg . idName) ids) } where -- Sigh, better map all the ids against the environment in diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index e737348..c8c922e 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -46,7 +46,6 @@ import Var ( Var ) import VarSet ( unionVarSet ) import VarEnv import Name ( hashName ) -import Packages ( HomeModules ) #if mingw32_TARGET_OS import Packages ( isDllName ) #endif @@ -72,6 +71,7 @@ import TyCon ( tyConArity ) import TysWiredIn ( boolTy, trueDataCon, falseDataCon ) import CostCentre ( CostCentre ) import BasicTypes ( Arity ) +import PackageConfig ( PackageId ) import Unique ( Unique ) import Outputable import DynFlags ( DynFlags, DynFlag(Opt_DictsCheap), dopt ) @@ -1223,7 +1223,7 @@ If this happens we simply make the RHS into an updatable thunk, and 'exectute' it rather than allocating it statically. \begin{code} -rhsIsStatic :: HomeModules -> CoreExpr -> Bool +rhsIsStatic :: PackageId -> CoreExpr -> Bool -- This function is called only on *top-level* right-hand sides -- Returns True if the RHS can be allocated statically, with -- no thunks involved at all. @@ -1284,7 +1284,7 @@ rhsIsStatic :: HomeModules -> CoreExpr -> Bool -- When opt_RuntimeTypes is on, we keep type lambdas and treat -- them as making the RHS re-entrant (non-updatable). -rhsIsStatic hmods rhs = is_static False rhs +rhsIsStatic this_pkg rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic -> CoreExpr -> Bool @@ -1311,7 +1311,7 @@ rhsIsStatic hmods rhs = is_static False rhs where go (Var f) n_val_args #if mingw32_TARGET_OS - | not (isDllName hmods (idName f)) + | not (isDllName this_pkg (idName f)) #endif = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) diff --git a/compiler/coreSyn/MkExternalCore.lhs b/compiler/coreSyn/MkExternalCore.lhs index 3910d5b..1d2ee0e 100644 --- a/compiler/coreSyn/MkExternalCore.lhs +++ b/compiler/coreSyn/MkExternalCore.lhs @@ -205,7 +205,7 @@ make_var_id :: Name -> C.Id make_var_id = make_id True make_mid :: Module -> C.Id -make_mid = moduleString +make_mid = showSDoc . pprModule make_qid :: Bool -> Name -> C.Qual C.Id make_qid is_var n = (mname,make_id is_var n) diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 45dc113..7b3847e 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -26,7 +26,9 @@ import DsBinds ( dsTopLHsBinds, decomposeRuleLhs, AutoScc(..) ) import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. -import Module ( Module, moduleEnvElts, delModuleEnv, moduleFS ) +import Module +import UniqFM ( eltsUFM, delFromUFM ) +import PackageConfig ( thPackageId ) import RdrName ( GlobalRdrEnv ) import NameSet import VarSet @@ -34,7 +36,6 @@ import Bag ( Bag, isEmptyBag, emptyBag ) import Rules ( roughTopNames ) import CoreLint ( showPass, endPass ) import CoreFVs ( ruleRhsFreeVars, exprsFreeNames ) -import Packages ( PackageState(thPackageId), PackageIdH(..) ) import ErrUtils ( doIfSet, dumpIfSet_dyn, printBagOfWarnings, errorsFound, WarnMsg ) import ListSetOps ( insertList ) @@ -62,7 +63,6 @@ deSugar hsc_env tcg_src = hsc_src, tcg_type_env = type_env, tcg_imports = imports, - tcg_home_mods = home_mods, tcg_exports = exports, tcg_dus = dus, tcg_inst_uses = dfun_uses_var, @@ -116,13 +116,10 @@ deSugar hsc_env ; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used ; th_used <- readIORef th_var -- Whether TH is used ; let used_names = allUses dus `unionNameSets` dfun_uses - thPackage = thPackageId (pkgState dflags) - pkgs | ExtPackage th_id <- thPackage, th_used - = insertList th_id (imp_dep_pkgs imports) - | otherwise - = imp_dep_pkgs imports + pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) + | otherwise = imp_dep_pkgs imports - dep_mods = moduleEnvElts (delModuleEnv (imp_dep_mods imports) mod) + dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove -- it before recording the modules on which this one depends! -- (We want to retain M.hi-boot in imp_dep_mods so that @@ -132,15 +129,20 @@ deSugar hsc_env dir_imp_mods = imp_mods imports - ; usages <- mkUsageInfo hsc_env home_mods dir_imp_mods dep_mods used_names + ; showPass dflags "Desugar 3" + + ; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names + + ; showPass dflags "Desugar 4" ; let -- Modules don't compare lexicographically usually, -- but we want them to do so here. le_mod :: Module -> Module -> Bool - le_mod m1 m2 = moduleFS m1 <= moduleFS m2 - le_dep_mod :: (Module, IsBootInterface) -> (Module, IsBootInterface) -> Bool - le_dep_mod (m1,_) (m2,_) = m1 `le_mod` m2 + le_mod m1 m2 = moduleNameFS (moduleName m1) + <= moduleNameFS (moduleName m2) + le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool + le_dep_mod (m1,_) (m2,_) = moduleNameFS m1 <= moduleNameFS m2 deps = Deps { dep_mods = sortLe le_dep_mod dep_mods, dep_pkgs = sortLe (<=) pkgs, @@ -152,7 +154,6 @@ deSugar hsc_env mg_boot = isHsBoot hsc_src, mg_exports = exports, mg_deps = deps, - mg_home_mods = home_mods, mg_usages = usages, mg_dir_imps = [m | (m,_,_) <- moduleEnvElts dir_imp_mods], mg_rdr_env = rdr_env, diff --git a/compiler/deSugar/DsForeign.lhs b/compiler/deSugar/DsForeign.lhs index e5cbbfb..46fc074 100644 --- a/compiler/deSugar/DsForeign.lhs +++ b/compiler/deSugar/DsForeign.lhs @@ -28,7 +28,7 @@ import SMRep ( argMachRep, typeCgRep ) import CoreUtils ( exprType, mkInlineMe ) import Id ( Id, idType, idName, mkSysLocal, setInlinePragma ) import Literal ( Literal(..), mkStringLit ) -import Module ( moduleFS ) +import Module ( moduleNameFS, moduleName ) import Name ( getOccString, NamedThing(..) ) import Type ( repType, coreEqType ) import TcType ( Type, mkFunTys, mkForAllTys, mkTyConApp, @@ -351,10 +351,10 @@ dsFExportDynamic :: Id -> DsM ([Binding], SDoc, SDoc) dsFExportDynamic id cconv = newSysLocalDs ty `thenDs` \ fe_id -> - getModuleDs `thenDs` \ mod_name -> + getModuleDs `thenDs` \ mod -> let -- hack: need to get at the name of the C stub we're about to generate. - fe_nm = mkFastString (unpackFS (zEncodeFS (moduleFS mod_name)) ++ "_" ++ toCName fe_id) + fe_nm = mkFastString (unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) ++ "_" ++ toCName fe_id) in newSysLocalDs arg_ty `thenDs` \ cback -> dsLookupGlobalId newStablePtrName `thenDs` \ newStablePtrId -> diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 88b0ba9..c1f2456 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, mkCoreTup, mkIntExpr ) +import DsUtils ( mkListExpr, mkStringExpr, mkIntExpr ) import DsMonad import qualified Language.Haskell.TH as TH @@ -37,7 +37,8 @@ import OccName ( isDataOcc, isTvOcc, occNameString ) -- ws previously used in this file. import qualified OccName -import Module ( Module, mkModule, moduleString ) +import Module ( Module, mkModule, moduleNameString, moduleName, + modulePackageId, mkModuleNameFS ) import Id ( Id, mkLocalId ) import OccName ( mkOccNameFS ) import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule, @@ -50,7 +51,7 @@ import TysWiredIn ( parrTyCon ) import CoreSyn import CoreUtils ( exprType ) import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan ) -import Maybe ( catMaybes ) +import PackageConfig ( thPackageId, packageIdString ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) ) import BasicTypes ( isBoxed ) import Outputable @@ -58,6 +59,7 @@ import Bag ( bagToList, unionManyBags ) import FastString ( unpackFS ) import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) ) +import Maybe ( catMaybes ) import Monad ( zipWithM ) import List ( sortBy ) @@ -905,14 +907,17 @@ globalVar :: Name -> DsM (Core TH.Name) globalVar name | isExternalName name = do { MkC mod <- coreStringLit name_mod + ; MkC pkg <- coreStringLit name_pkg ; MkC occ <- occNameLit name - ; rep2 mk_varg [mod,occ] } + ; rep2 mk_varg [pkg,mod,occ] } | otherwise = do { MkC occ <- occNameLit name ; MkC uni <- coreIntLit (getKey (getUnique name)) ; rep2 mkNameLName [occ,uni] } where - name_mod = moduleString (nameModule name) + mod = nameModule name + name_mod = moduleNameString (moduleName mod) + name_pkg = packageIdString (modulePackageId mod) name_occ = nameOccName name mk_varg | OccName.isDataOcc name_occ = mkNameG_dName | OccName.isVarOcc name_occ = mkNameG_vName @@ -1293,9 +1298,6 @@ 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) } @@ -1387,8 +1389,10 @@ templateHaskellNames = [ fieldPatQTyConName, fieldExpQTyConName, funDepTyConName] thSyn :: Module -thSyn = mkModule "Language.Haskell.TH.Syntax" -thLib = mkModule "Language.Haskell.TH.Lib" +thSyn = mkTHModule FSLIT("Language.Haskell.TH.Syntax") +thLib = mkTHModule FSLIT("Language.Haskell.TH.Lib") + +mkTHModule m = mkModule thPackageId (mkModuleNameFS m) mk_known_key_name mod space str uniq = mkExternalName uniq mod (mkOccNameFS space str) diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index f24dee4..ae76bfd 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -38,7 +38,7 @@ import HsSyn ( HsExpr, HsMatchContext, Pat ) import TcIface ( tcIfaceGlobal ) import RdrName ( GlobalRdrEnv ) import HscTypes ( TyThing(..), TypeEnv, HscEnv, - tyThingId, tyThingTyCon, tyThingDataCon, unQualInScope ) + tyThingId, tyThingTyCon, tyThingDataCon, mkPrintUnqualified ) import Bag ( emptyBag, snocBag, Bag ) import DataCon ( DataCon ) import TyCon ( TyCon ) @@ -176,7 +176,7 @@ initDs hsc_env mod rdr_env type_env thing_inside ; return (res, mapBag mk_warn warns) } where - print_unqual = unQualInScope rdr_env + print_unqual = mkPrintUnqualified rdr_env mk_warn :: (SrcSpan,SDoc) -> WarnMsg mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc diff --git a/compiler/ghci/ByteCodeLink.lhs b/compiler/ghci/ByteCodeLink.lhs index 875f1d6..d294178 100644 --- a/compiler/ghci/ByteCodeLink.lhs +++ b/compiler/ghci/ByteCodeLink.lhs @@ -19,19 +19,21 @@ import ByteCodeItbls ( ItblEnv, ItblPtr ) import ByteCodeAsm ( UnlinkedBCO(..), BCOPtr(..), sizeSS, ssElts ) import ObjLink ( lookupSymbol ) -import Name ( Name, nameModule, nameOccName, isExternalName ) +import Name ( Name, nameModule, nameOccName ) +#ifdef DEBUG +import Name ( isExternalName ) +#endif import NameEnv import OccName ( occNameFS ) import PrimOp ( PrimOp, primOpOcc ) -import Module ( moduleFS ) +import Module +import PackageConfig ( mainPackageId, packageIdFS ) import FastString ( FastString(..), unpackFS, zEncodeFS ) -import Outputable import Panic ( GhcException(..) ) -- Standard libraries import GHC.Word ( Word(..) ) -import Data.Array.IArray ( listArray ) import Data.Array.Base import GHC.Arr ( STArray(..) ) @@ -256,8 +258,17 @@ linkFail who what -- HACKS!!! ToDo: cleaner nameToCLabel :: Name -> String{-suffix-} -> String nameToCLabel n suffix - = unpackFS (zEncodeFS (moduleFS (nameModule n))) - ++ '_': unpackFS (zEncodeFS (occNameFS (nameOccName n))) ++ '_':suffix + = if pkgid /= mainPackageId + then package_part ++ '_': qual_name + else qual_name + where + pkgid = modulePackageId mod + mod = nameModule n + package_part = unpackFS (zEncodeFS (packageIdFS (modulePackageId mod))) + module_part = unpackFS (zEncodeFS (moduleNameFS (moduleName mod))) + occ_part = unpackFS (zEncodeFS (occNameFS (nameOccName n))) + qual_name = module_part ++ '_':occ_part ++ '_':suffix + primopToCLabel :: PrimOp -> String{-suffix-} -> String primopToCLabel primop suffix diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 55384bc..8a20fb1 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -31,9 +31,9 @@ import PrelNames ( breakpointJumpName, breakpointCondJumpName ) -- The GHC interface import qualified GHC -import GHC ( Session, verbosity, dopt, DynFlag(..), Target(..), +import GHC ( Session, dopt, DynFlag(..), Target(..), TargetId(..), DynFlags(..), - pprModule, Type, Module, SuccessFlag(..), + pprModule, Type, Module, ModuleName, SuccessFlag(..), TyThing(..), Name, LoadHowMuch(..), Phase, GhcException(..), showGhcException, CheckedModule(..), SrcLoc ) @@ -45,7 +45,6 @@ import PprTyThing import Outputable -- for createtags (should these come via GHC?) -import Module ( moduleString ) import Name ( nameSrcLoc, nameModule, nameOccName ) import OccName ( pprOccName ) import SrcLoc ( isGoodSrcLoc, srcLocFile, srcLocLine, srcLocCol ) @@ -95,7 +94,6 @@ import System.IO.Error as IO import Data.Char import Control.Monad as Monad import Foreign.StablePtr ( newStablePtr ) -import Text.Printf import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) @@ -242,13 +240,15 @@ jumpFunction session@(Session ref) (I# idsPtr) hValues location b ic_type_env = new_type_env } writeIORef ref (hsc_env { hsc_IC = new_ic }) is_tty <- hIsTerminalDevice stdin + prel_mod <- GHC.findModule session prel_name Nothing withExtendedLinkEnv (zip names hValues) $ startGHCi (interactiveLoop is_tty True) GHCiState{ progname = "", args = [], prompt = location++"> ", session = session, - options = [] } + options = [], + prelude = prel_mod } writeIORef ref hsc_env putStrLn $ "Returning to normal execution..." return b @@ -284,7 +284,8 @@ interactiveUI session srcs maybe_expr = do hSetBuffering stdin NoBuffering -- initial context is just the Prelude - GHC.setContext session [] [prelude_mod] + prel_mod <- GHC.findModule session prel_name Nothing + GHC.setContext session [] [prel_mod] #ifdef USE_READLINE Readline.initialize @@ -305,7 +306,8 @@ interactiveUI session srcs maybe_expr = do args = [], prompt = "%s> ", session = session, - options = [] } + options = [], + prelude = prel_mod } #ifdef USE_READLINE Readline.resetTerminal Nothing @@ -313,6 +315,8 @@ interactiveUI session srcs maybe_expr = do return () +prel_name = GHC.mkModuleName "Prelude" + runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () runGHCi paths maybe_expr = do let read_dot_files = not opt_IgnoreDotGhci @@ -807,7 +811,7 @@ loadModule' files = do checkModule :: String -> GHCi () checkModule m = do - let modl = GHC.mkModule m + let modl = GHC.mkModuleName m session <- getSession result <- io (GHC.checkModule session modl) case result of @@ -816,7 +820,7 @@ checkModule m = do case checkedModuleInfo r of Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> let - (local,global) = partition ((== modl) . GHC.nameModule) scope + (local,global) = partition ((== modl) . GHC.moduleName . GHC.nameModule) scope in (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) @@ -832,22 +836,23 @@ reloadModule "" = do reloadModule m = do io (revertCAFs) -- always revert CAFs on reload. session <- getSession - ok <- io (GHC.load session (LoadUpTo (GHC.mkModule m))) + ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m))) afterLoad ok session afterLoad ok session = do io (revertCAFs) -- always revert CAFs on load. graph <- io (GHC.getModuleGraph session) - graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod) graph + graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph setContextAfterLoad session graph' - modulesLoadedMsg ok (map GHC.ms_mod graph') + modulesLoadedMsg ok (map GHC.ms_mod_name graph') #if defined(GHCI) && defined(BREAKPOINT) io (extendLinkEnv [(breakpointJumpName,unsafeCoerce# (jumpFunction session)) ,(breakpointCondJumpName,unsafeCoerce# (jumpCondFunction session))]) #endif setContextAfterLoad session [] = do - io (GHC.setContext session [] [prelude_mod]) + prel_mod <- getPrelude + io (GHC.setContext session [] [prel_mod]) setContextAfterLoad session ms = do -- load a target if one is available, otherwise load the topmost module. targets <- io (GHC.getTargets session) @@ -864,7 +869,7 @@ setContextAfterLoad session ms = do (m:_) -> Just m summary `matches` Target (TargetModule m) _ - = GHC.ms_mod summary == m + = GHC.ms_mod_name summary == m summary `matches` Target (TargetFile f _) _ | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f' summary `matches` target @@ -873,17 +878,19 @@ setContextAfterLoad session ms = do load_this summary | m <- GHC.ms_mod summary = do b <- io (GHC.moduleIsInterpreted session m) if b then io (GHC.setContext session [m] []) - else io (GHC.setContext session [] [prelude_mod,m]) + else do + prel_mod <- getPrelude + io (GHC.setContext session [] [prel_mod,m]) -modulesLoadedMsg :: SuccessFlag -> [Module] -> GHCi () +modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi () modulesLoadedMsg ok mods = do dflags <- getDynFlags when (verbosity dflags > 0) $ do let mod_commas | null mods = text "none." | otherwise = hsep ( - punctuate comma (map pprModule mods)) <> text "." + punctuate comma (map ppr mods)) <> text "." case ok of Failed -> io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas))) @@ -950,8 +957,9 @@ createTagsFile session tagskind tagFile = do is_interpreted <- GHC.moduleIsInterpreted session m -- should we just skip these? when (not is_interpreted) $ - throwDyn (CmdLineError ("module '" ++ moduleString m ++ "' is not interpreted")) - + throwDyn (CmdLineError ("module '" + ++ GHC.moduleNameString (GHC.moduleName m) + ++ "' is not interpreted")) mbModInfo <- GHC.getModuleInfo session m let unqual | Just modinfo <- mbModInfo, @@ -1039,8 +1047,7 @@ browseCmd m = browseModule m exports_only = do s <- getSession - - let modl = GHC.mkModule m + modl <- io $ GHC.findModule s (GHC.mkModuleName m) Nothing is_interpreted <- io (GHC.moduleIsInterpreted s modl) when (not is_interpreted && not exports_only) $ throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted")) @@ -1048,7 +1055,8 @@ browseModule m exports_only = do -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified (as,bs) <- io (GHC.getContext s) - io (if exports_only then GHC.setContext s [] [prelude_mod,modl] + prel_mod <- getPrelude + io (if exports_only then GHC.setContext s [] [prel_mod,modl] else GHC.setContext s [modl] []) unqual <- io (GHC.getPrintUnqual s) io (GHC.setContext s as bs) @@ -1089,47 +1097,53 @@ setContext str sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m -newContext mods = do - session <- getSession - (as,bs) <- separate session mods [] [] - let bs' = if null as && prelude_mod `notElem` bs then prelude_mod:bs else bs - io (GHC.setContext session as bs') - -separate :: Session -> [String] -> [Module] -> [Module] - -> GHCi ([Module],[Module]) +separate :: Session -> [String] -> [Module] -> [Module] + -> GHCi ([Module],[Module]) separate session [] as bs = return (as,bs) -separate session (('*':m):ms) as bs = do - let modl = GHC.mkModule m - b <- io (GHC.moduleIsInterpreted session modl) - if b then separate session ms (modl:as) bs - else throwDyn (CmdLineError ("module '" ++ m ++ "' is not interpreted")) -separate session (m:ms) as bs = separate session ms as (GHC.mkModule m:bs) - -prelude_mod = GHC.mkModule "Prelude" +separate session (('*':str):ms) as bs = do + m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing + b <- io $ GHC.moduleIsInterpreted session m + if b then separate session ms (m:as) bs + else throwDyn (CmdLineError ("module '" + ++ GHC.moduleNameString (GHC.moduleName m) + ++ "' is not interpreted")) +separate session (str:ms) as bs = do + m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing + separate session ms as (m:bs) + +newContext :: [String] -> GHCi () +newContext strs = do + s <- getSession + (as,bs) <- separate s strs [] [] + prel_mod <- getPrelude + let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs + io $ GHC.setContext s as bs' -addToContext mods = do - cms <- getSession - (as,bs) <- io (GHC.getContext cms) +addToContext :: [String] -> GHCi () +addToContext strs = do + s <- getSession + (as,bs) <- io $ GHC.getContext s - (as',bs') <- separate cms mods [] [] + (new_as,new_bs) <- separate s strs [] [] - let as_to_add = as' \\ (as ++ bs) - bs_to_add = bs' \\ (as ++ bs) + let as_to_add = new_as \\ (as ++ bs) + bs_to_add = new_bs \\ (as ++ bs) - io (GHC.setContext cms (as ++ as_to_add) (bs ++ bs_to_add)) + io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add) -removeFromContext mods = do - cms <- getSession - (as,bs) <- io (GHC.getContext cms) +removeFromContext :: [String] -> GHCi () +removeFromContext strs = do + s <- getSession + (as,bs) <- io $ GHC.getContext s - (as_to_remove,bs_to_remove) <- separate cms mods [] [] + (as_to_remove,bs_to_remove) <- separate s strs [] [] let as' = as \\ (as_to_remove ++ bs_to_remove) bs' = bs \\ (as_to_remove ++ bs_to_remove) - io (GHC.setContext cms as' bs') + io $ GHC.setContext s as' bs' ---------------------------------------------------------------------------- -- Code for `:set' @@ -1357,7 +1371,7 @@ completeModule w = do completeHomeModule w = do s <- restoreSession g <- GHC.getModuleGraph s - let home_mods = map GHC.ms_mod g + let home_mods = map GHC.ms_mod_name g return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods)) completeSetOptions w = do @@ -1393,9 +1407,9 @@ getCommonPrefix (s:ss) = foldl common s ss | c == d = c : common cs ds | otherwise = "" -allExposedModules :: DynFlags -> [Module] +allExposedModules :: DynFlags -> [ModuleName] allExposedModules dflags - = map GHC.mkModule (concat (map exposedModules (filter exposed (eltsUFM pkg_db)))) + = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db)))) where pkg_db = pkgIdMap (pkgState dflags) #else @@ -1418,7 +1432,8 @@ data GHCiState = GHCiState args :: [String], prompt :: String, session :: GHC.Session, - options :: [GHCiOption] + options :: [GHCiOption], + prelude :: Module } data GHCiOption @@ -1445,6 +1460,7 @@ setGHCiState s = GHCi $ \r -> writeIORef r s -- for convenience... getSession = getGHCiState >>= return . session +getPrelude = getGHCiState >>= return . prelude GLOBAL_VAR(saved_sess, no_saved_sess, Session) no_saved_sess = error "no saved_ses" diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs index cec1047..26f40eb 100644 --- a/compiler/ghci/Linker.lhs +++ b/compiler/ghci/Linker.lhs @@ -30,16 +30,19 @@ import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) import Packages import DriverPhases ( isObjectFilename, isDynLibFilename ) -import Finder ( findModule, findObjectLinkableMaybe, FindResult(..) ) +import Finder ( findHomeModule, findObjectLinkableMaybe, + FindResult(..) ) import HscTypes import Name ( Name, nameModule, isExternalName, isWiredInName ) import NameEnv import NameSet ( nameSetToList ) +import UniqFM ( lookupUFM ) import Module import ListSetOps ( minusList ) import DynFlags ( DynFlags(..), getOpts ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Outputable +import PackageConfig ( rtsPackageId ) import Panic ( GhcException(..) ) import Util ( zipLazy, global, joinFileExt, joinFileName, suffixOf, replaceFilenameSuffix ) @@ -58,7 +61,10 @@ import System.IO ( putStr, putStrLn, hPutStrLn, stderr, fixIO ) import System.Directory ( doesFileExist ) import Control.Exception ( block, throwDyn, bracket ) -import Maybe ( isJust, fromJust ) +import Maybe ( fromJust ) +#ifdef DEBUG +import Maybe ( isJust ) +#endif #if __GLASGOW_HASKELL__ >= 503 import GHC.IOBase ( IO(..) ) @@ -122,9 +128,7 @@ emptyPLS dflags = PersistentLinkerState { -- -- The linker's symbol table is populated with RTS symbols using an -- explicit list. See rts/Linker.c for details. - where init_pkgs - | ExtPackage rts_id <- rtsPackageId (pkgState dflags) = [rts_id] - | otherwise = [] + where init_pkgs = [rtsPackageId] \end{code} \begin{code} @@ -363,7 +367,6 @@ linkExpr hsc_env span root_ul_bco }} where hpt = hsc_HPT hsc_env - dflags = hsc_dflags hsc_env free_names = nameSetToList (bcoFreeNames root_ul_bco) needed_mods :: [Module] @@ -413,7 +416,8 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods mods_needed = nub (concat mods_s) `minusList` linked_mods ; pkgs_needed = nub (concat pkgs_s) `minusList` pkgs_loaded pls ; - linked_mods = map linkableModule (objs_loaded pls ++ bcos_loaded pls) + linked_mods = map (moduleName.linkableModule) + (objs_loaded pls ++ bcos_loaded pls) } ; -- 3. For each dependent module, find its linkable @@ -423,19 +427,22 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods return (lnks_needed, pkgs_needed) } where - get_deps :: Module -> ([Module],[PackageId]) + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + + get_deps :: Module -> ([ModuleName],[PackageId]) -- Get the things needed for the specified module -- This is rather similar to the code in RnNames.importsFromImportDecl get_deps mod - | ExtPackage p <- mi_package iface - = ([], p : dep_pkgs deps) + | pkg /= this_pkg + = ([], pkg : dep_pkgs deps) | otherwise - = (mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) + = (moduleName mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) where - iface = get_iface mod - deps = mi_deps iface + pkg = modulePackageId mod + deps = mi_deps (get_iface mod) - get_iface mod = case lookupIface hpt pit mod of + get_iface mod = case lookupIfaceByModule dflags hpt pit mod of Just iface -> iface Nothing -> pprPanic "getLinkDeps" (no_iface mod) no_iface mod = ptext SLIT("No iface for") <+> ppr mod @@ -451,23 +458,22 @@ getLinkDeps hsc_env hpt pit maybe_normal_osuf span mods -- This one is a build-system bug get_linkable maybe_normal_osuf mod_name -- A home-package module - | Just mod_info <- lookupModuleEnv hpt mod_name + | Just mod_info <- lookupUFM hpt mod_name = ASSERT(isJust (hm_linkable mod_info)) adjust_linkable (fromJust (hm_linkable mod_info)) | otherwise - = -- It's not in the HPT because we are in one shot mode, + = do -- It's not in the HPT because we are in one shot mode, -- so use the Finder to get a ModLocation... - do { mb_stuff <- findModule hsc_env mod_name False ; - case mb_stuff of { - Found loc _ -> found loc mod_name ; + mb_stuff <- findHomeModule hsc_env mod_name + case mb_stuff of + Found loc mod -> found loc mod _ -> no_obj mod_name - }} - where - found loc mod_name = do { + + found loc mod = do { -- ...and then find the linkable for it - mb_lnk <- findObjectLinkableMaybe mod_name loc ; + mb_lnk <- findObjectLinkableMaybe mod loc ; case mb_lnk of { - Nothing -> no_obj mod_name ; + Nothing -> no_obj mod ; Just lnk -> adjust_linkable lnk }} diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs index 77e9e08..88d8954 100644 --- a/compiler/hsSyn/Convert.lhs +++ b/compiler/hsSyn/Convert.lhs @@ -17,9 +17,10 @@ import HsSyn as Hs import qualified Class (FunDep) import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName ) import qualified Name ( Name, mkInternalName, getName ) -import Module ( Module, mkModule ) +import Module ( ModuleName, mkModuleName, mkModule ) import RdrHsSyn ( mkClassDecl, mkTyData ) import qualified OccName +import PackageConfig ( PackageId, stringToPackageId ) import OccName ( startsVarId, startsVarSym, startsConId, startsConSym, pprNameSpace ) import SrcLoc ( Located(..), SrcSpan ) @@ -569,7 +570,7 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName -- which will give confusing error messages later -- -- The strict applications ensure that any buried exceptions get forced -thRdrName ctxt_ns occ (TH.NameG th_ns mod) = (mkOrig $! (mk_mod mod)) $! (mk_occ (mk_ghc_ns th_ns) occ) +thRdrName ctxt_ns occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcLoc) thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ) thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq) @@ -617,8 +618,11 @@ mk_ghc_ns TH.DataName = OccName.dataName mk_ghc_ns TH.TcClsName = OccName.tcClsName mk_ghc_ns TH.VarName = OccName.varName -mk_mod :: TH.ModName -> Module -mk_mod mod = mkModule (TH.modString mod) +mk_mod :: TH.ModName -> ModuleName +mk_mod mod = mkModuleName (TH.modString mod) + +mk_pkg :: TH.ModName -> PackageId +mk_pkg pkg = stringToPackageId (TH.pkgString pkg) mk_uniq :: Int# -> Unique mk_uniq u = mkUniqueGrimily (I# u) diff --git a/compiler/hsSyn/HsImpExp.lhs b/compiler/hsSyn/HsImpExp.lhs index 220afb7..f63d86a 100644 --- a/compiler/hsSyn/HsImpExp.lhs +++ b/compiler/hsSyn/HsImpExp.lhs @@ -8,7 +8,7 @@ module HsImpExp where #include "HsVersions.h" -import Module ( Module ) +import Module ( ModuleName ) import Outputable import FastString import SrcLoc ( Located(..) ) @@ -26,10 +26,10 @@ One per \tr{import} declaration in a module. type LImportDecl name = Located (ImportDecl name) data ImportDecl name - = ImportDecl (Located Module) -- module name + = ImportDecl (Located ModuleName) -- module name Bool -- True <=> {-# SOURCE #-} import Bool -- True => qualified - (Maybe Module) -- as Module + (Maybe ModuleName) -- as Module (Maybe (Bool, [LIE name])) -- (True => hiding, names) \end{code} @@ -72,7 +72,7 @@ data IE name | IEThingAbs name -- Class/Type (can't tell) | IEThingAll name -- Class/Type plus all methods/constructors | IEThingWith name [name] -- Class/Type plus some methods/constructors - | IEModuleContents Module -- (Export Only) + | IEModuleContents ModuleName -- (Export Only) \end{code} \begin{code} diff --git a/compiler/hsSyn/HsSyn.lhs b/compiler/hsSyn/HsSyn.lhs index a9982a6..0efa1e3 100644 --- a/compiler/hsSyn/HsSyn.lhs +++ b/compiler/hsSyn/HsSyn.lhs @@ -40,14 +40,14 @@ import HsUtils import IfaceSyn ( IfaceBinding ) import Outputable import SrcLoc ( Located(..) ) -import Module ( Module ) +import Module ( Module, ModuleName ) \end{code} All we actually declare here is the top-level structure for a module. \begin{code} data HsModule name = HsModule - (Maybe (Located Module))-- Nothing => "module X where" is omitted + (Maybe (Located ModuleName))-- Nothing => "module X where" is omitted -- (in which case the next field is Nothing too) (Maybe [LIE name]) -- Export list; Nothing => export list omitted, so export everything -- Just [] => export *nothing* diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 631a286..6af109c 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -15,7 +15,6 @@ import NewDemand import IfaceSyn import VarEnv import InstEnv ( OverlapFlag(..) ) -import Packages ( PackageIdH(..) ) import Class ( DefMeth(..) ) import CostCentre import StaticFlags ( opt_HiVersion, v_Build_tag ) @@ -97,7 +96,6 @@ instance Binary ModIface where mi_module = mod, mi_boot = is_boot, mi_mod_vers = mod_vers, - mi_package = _, -- we ignore the package on output mi_orphan = orphan, mi_deps = deps, mi_usages = usages, @@ -162,7 +160,6 @@ instance Binary ModIface where rules <- {-# SCC "bin_rules" #-} lazyGet bh rule_vers <- get bh return (ModIface { - mi_package = HomePackage, -- to be filled in properly later mi_module = mod_name, mi_boot = is_boot, mi_mod_vers = mod_vers, diff --git a/compiler/iface/IfaceEnv.lhs b/compiler/iface/IfaceEnv.lhs index c7e78b3..3eceaa0 100644 --- a/compiler/iface/IfaceEnv.lhs +++ b/compiler/iface/IfaceEnv.lhs @@ -35,9 +35,9 @@ import Name ( Name, nameUnique, nameModule, import NameSet ( NameSet, emptyNameSet, addListToNameSet ) import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, mapOccEnv, occNameFS, lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) -import PrelNames ( gHC_PRIM, pREL_TUP ) -import Module ( Module, emptyModuleEnv, - lookupModuleEnv, extendModuleEnv_C ) +import PrelNames ( gHC_PRIM, dATA_TUP ) +import Module ( Module, emptyModuleEnv, ModuleName, modulePackageId, + lookupModuleEnv, extendModuleEnv_C, mkModule ) import UniqFM ( lookupUFM, addListToUFM ) import FastString ( FastString ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply ) @@ -230,7 +230,7 @@ newIPName occ_name_ip \begin{code} lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache nc mod occ - | mod == pREL_TUP || mod == gHC_PRIM, -- Boxed tuples from one, + | mod == dATA_TUP || mod == gHC_PRIM, -- Boxed tuples from one, Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other = -- Special case for tuples; there are too many -- of them to pre-populate the original-name cache @@ -340,7 +340,7 @@ lookupIfaceTc other_tc = return (ifaceTyConName other_tc) lookupIfaceExt :: IfaceExtName -> IfL Name lookupIfaceExt (ExtPkg mod occ) = lookupOrig mod occ -lookupIfaceExt (HomePkg mod occ _) = lookupOrig mod occ +lookupIfaceExt (HomePkg mod occ _) = lookupHomePackage mod occ lookupIfaceExt (LocalTop occ) = lookupIfaceTop occ lookupIfaceExt (LocalTopSub occ _) = lookupIfaceTop occ @@ -349,6 +349,12 @@ lookupIfaceTop :: OccName -> IfL Name lookupIfaceTop occ = do { env <- getLclEnv; lookupOrig (if_mod env) occ } +lookupHomePackage :: ModuleName -> OccName -> IfL Name +lookupHomePackage mod_name occ + = do { env <- getLclEnv; + ; let this_pkg = modulePackageId (if_mod env) + ; lookupOrig (mkModule this_pkg mod_name) occ } + newIfaceName :: OccName -> IfL Name newIfaceName occ = do { uniq <- newUnique diff --git a/compiler/iface/IfaceType.lhs b/compiler/iface/IfaceType.lhs index bf0f383..a487489 100644 --- a/compiler/iface/IfaceType.lhs +++ b/compiler/iface/IfaceType.lhs @@ -10,7 +10,7 @@ module IfaceType ( IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName, - ifaceTyConName, interactiveExtNameFun, + ifaceTyConName, -- Conversion from Type -> IfaceType toIfaceType, toIfacePred, toIfaceContext, @@ -34,7 +34,7 @@ import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, char import OccName ( OccName, parenSymOcc, occNameFS ) import Name ( Name, getName, getOccName, nameModule, nameOccName, wiredInNameTyThing_maybe ) -import Module ( Module ) +import Module ( Module, ModuleName ) import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity ) import Outputable import FastString @@ -49,13 +49,15 @@ import FastString \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 + = 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 Module OccName Version -- From another module in home package; - -- has version #; in all other respects, - -- HomePkg and ExtPkg are the same + | 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 @@ -79,14 +81,6 @@ ifaceExtOcc (ExtPkg _ occ) = occ ifaceExtOcc (HomePkg _ occ _) = occ ifaceExtOcc (LocalTop occ) = occ ifaceExtOcc (LocalTopSub occ _) = occ - -interactiveExtNameFun :: PrintUnqualified -> Name-> IfaceExtName -interactiveExtNameFun print_unqual name - | print_unqual mod occ = LocalTop occ - | otherwise = ExtPkg mod occ - where - mod = nameModule name - occ = nameOccName name \end{code} @@ -200,15 +194,12 @@ maybeParen ctxt_prec inner_prec pretty -- 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) = pprExt mod occ - ppr (HomePkg mod occ vers) = pprExt mod occ <> braces (ppr vers) + 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? - -pprExt :: Module -> OccName -> SDoc -- No need to worry about printing unqualified becuase that was handled -- in the transiation to IfaceSyn -pprExt mod occ = ppr mod <> dot <> ppr occ instance Outputable IfaceBndr where ppr (IfaceIdBndr bndr) = pprIfaceIdBndr bndr diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 8c496f7..8bcf987 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -5,7 +5,7 @@ \begin{code} module LoadIface ( - loadInterface, loadHomeInterface, loadWiredInHomeIface, + loadInterface, loadInterfaceForName, loadWiredInHomeIface, loadSrcInterface, loadSysInterface, loadOrphanModules, findAndReadIface, readIface, -- Used when reading the module's old interface loadDecls, ifaceStats, discardDeclPrags, @@ -16,9 +16,7 @@ module LoadIface ( import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst ) -import Packages ( PackageState(..), PackageIdH(..), isHomePackage ) -import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ), - isOneShot ) +import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceIdInfo(..) ) import IfaceEnv ( newGlobalBinder ) @@ -43,17 +41,15 @@ import Name ( Name {-instance NamedThing-}, getOccName, nameModule, nameIsLocalOrFrom, isWiredInName ) import NameEnv import MkId ( seqId ) -import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv, - addBootSuffix_maybe, - extendModuleEnv, lookupModuleEnv, moduleString - ) +import Module import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc ) import SrcLoc ( importedSrcLoc ) import Maybes ( MaybeErr(..) ) -import FastString ( mkFastString ) import ErrUtils ( Message ) -import Finder ( findModule, findPackageModule, FindResult(..), cantFindError ) +import Finder ( findImportedModule, findExactModule, + FindResult(..), cantFindError ) +import UniqFM import Outputable import BinIface ( readBinIface ) import Panic ( ghcError, tryMost, showException, GhcException(..) ) @@ -70,22 +66,31 @@ import List ( nub ) %************************************************************************ \begin{code} -loadSrcInterface :: SDoc -> Module -> IsBootInterface -> RnM ModIface --- This is called for each 'import' declaration in the source code --- On a failure, fail in the monad with an error message - -loadSrcInterface doc mod want_boot - = do { mb_iface <- initIfaceTcRn $ - loadInterface doc mod (ImportByUser want_boot) - ; case mb_iface of - Failed err -> failWithTc (elaborate err) - Succeeded iface -> return iface - } +-- | Load the interface corresponding to an @import@ directive in +-- source code. On a failure, fail in the monad with an error message. +loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface +loadSrcInterface doc mod want_boot = do + -- We must first find which Module this import refers to. This involves + -- calling the Finder, which as a side effect will search the filesystem + -- and create a ModLocation. If successful, loadIface will read the + -- interface; it will call the Finder again, but the ModLocation will be + -- cached from the first search. + hsc_env <- getTopEnv + res <- ioToIOEnv $ findImportedModule hsc_env mod Nothing + case res of + Found _ mod -> do + mb_iface <- initIfaceTcRn $ loadInterface doc mod (ImportByUser want_boot) + case mb_iface of + Failed err -> failWithTc (elaborate err) + Succeeded iface -> return iface + err -> + let dflags = hsc_dflags hsc_env in + failWithTc (elaborate (cantFindError dflags mod err)) where elaborate err = hang (ptext SLIT("Failed to load interface for") <+> quotes (ppr mod) <> colon) 4 err ---------------- +-- | Load interfaces for a collection of orphan modules. loadOrphanModules :: [Module] -> TcM () loadOrphanModules mods | null mods = returnM () @@ -98,9 +103,9 @@ loadOrphanModules mods load mod = loadSysInterface (mk_doc mod) mod mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") ---------------- -loadHomeInterface :: SDoc -> Name -> TcRn ModIface -loadHomeInterface doc name +-- | Loads the interface for a given Name. +loadInterfaceForName :: SDoc -> Name -> TcRn ModIface +loadInterfaceForName doc name = do { #ifdef DEBUG -- Should not be called with a name from the module being compiled @@ -110,19 +115,17 @@ loadHomeInterface doc name initIfaceTcRn $ loadSysInterface doc (nameModule name) } ---------------- -loadWiredInHomeIface :: Name -> IfM lcl () --- A IfM function to load the home interface for a wired-in thing, +-- | An 'IfM' function to load the home interface for a wired-in thing, -- so that we're sure that we see its instance declarations and rules +loadWiredInHomeIface :: Name -> IfM lcl () loadWiredInHomeIface name = ASSERT( isWiredInName name ) - do { loadSysInterface doc (nameModule name); return () } + do loadSysInterface doc (nameModule name); return () where doc = ptext SLIT("Need home interface for wired-in thing") <+> ppr name ---------------- +-- | A wrapper for 'loadInterface' that throws an exception if it fails loadSysInterface :: SDoc -> Module -> IfM lcl ModIface --- A wrapper for loadInterface that Throws an exception if it fails loadSysInterface doc mod_name = do { mb_iface <- loadInterface doc mod_name ImportBySystem ; case mb_iface of @@ -142,7 +145,7 @@ loadSysInterface doc mod_name %********************************************************* \begin{code} -loadInterface :: SDoc -> Module -> WhereFrom +loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr Message ModIface) -- If it can't find a suitable interface file, we @@ -161,7 +164,8 @@ loadInterface doc_str mod from ; traceIf (text "Considering whether to load" <+> ppr mod <+> ppr from) -- Check whether we have the interface already - ; case lookupIfaceByModule hpt (eps_PIT eps) mod of { + ; dflags <- getDOpts + ; case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of { Just iface -> returnM (Succeeded iface) ; -- Already loaded -- The (src_imp == mi_boot iface) test checks that the already-loaded @@ -173,7 +177,7 @@ loadInterface doc_str mod from ImportByUser usr_boot -> usr_boot ImportBySystem -> sys_boot - ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod + ; mb_dep = lookupUFM (eps_is_boot eps) (moduleName mod) ; sys_boot = case mb_dep of Just (_, is_boot) -> is_boot Nothing -> False @@ -181,13 +185,11 @@ loadInterface doc_str mod from } -- based on the dependencies in directly-imported modules -- READ THE MODULE IN - ; let explicit | ImportByUser _ <- from = True - | otherwise = False - ; read_result <- findAndReadIface explicit doc_str mod hi_boot_file + ; read_result <- findAndReadIface doc_str mod hi_boot_file ; dflags <- getDOpts ; case read_result of { Failed err -> do - { let fake_iface = emptyModIface HomePackage mod + { let fake_iface = emptyModIface mod ; updateEps_ $ \eps -> eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } @@ -198,9 +200,10 @@ loadInterface doc_str mod from -- Found and parsed! Succeeded (iface, file_path) -- Sanity check: - | ImportBySystem <- from, -- system-importing... - isHomePackage (mi_package iface), -- ...a home-package module - Nothing <- mb_dep -- ...that we know nothing about + | ImportBySystem <- from, -- system-importing... + modulePackageId (mi_module iface) == thisPackage dflags, + -- a home-package module... + Nothing <- mb_dep -- that we know nothing about -> returnM (Failed (badDepMsg mod)) | otherwise -> @@ -312,7 +315,7 @@ loadDecl ignore_prags mod (_version, decl) -- imported name, to fix the module correctly in the cache mk_new_bndr mod mb_parent occ = newGlobalBinder mod occ mb_parent - (importedSrcLoc (moduleString mod)) + (importedSrcLoc (showSDoc (pprModule mod))) doc = ptext SLIT("Declaration for") <+> ppr (ifName decl) @@ -383,8 +386,7 @@ ifaceDeclSubBndrs _other = [] %********************************************************* \begin{code} -findAndReadIface :: Bool -- True <=> explicit user import - -> SDoc -> Module +findAndReadIface :: SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) @@ -394,74 +396,62 @@ findAndReadIface :: Bool -- True <=> explicit user import -- It *doesn't* add an error to the monad, because -- sometimes it's ok to fail... see notes with loadInterface -findAndReadIface explicit doc_str mod_name hi_boot_file +findAndReadIface doc_str mod hi_boot_file = do { traceIf (sep [hsep [ptext SLIT("Reading"), if hi_boot_file then ptext SLIT("[boot]") else empty, ptext SLIT("interface for"), - ppr mod_name <> semi], + ppr mod <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)]) -- Check for GHC.Prim, and return its static interface ; dflags <- getDOpts - ; let base_pkg = basePackageId (pkgState dflags) - ; if mod_name == gHC_PRIM - then returnM (Succeeded (ghcPrimIface{ mi_package = base_pkg }, - "")) + ; if mod == gHC_PRIM + then returnM (Succeeded (ghcPrimIface, + "")) else do -- Look for the file ; hsc_env <- getTopEnv - ; mb_found <- ioToIOEnv (findHiFile hsc_env explicit mod_name hi_boot_file) + ; mb_found <- ioToIOEnv (findHiFile hsc_env mod hi_boot_file) ; case mb_found of { Failed err -> do { traceIf (ptext SLIT("...not found")) ; dflags <- getDOpts - ; returnM (Failed (cantFindError dflags mod_name err)) } ; + ; returnM (Failed (cantFindError dflags (moduleName mod) err)) } ; - Succeeded (file_path, pkg) -> do + Succeeded file_path -> do -- Found file, so read it { traceIf (ptext SLIT("readIFace") <+> text file_path) - ; read_result <- readIface mod_name file_path hi_boot_file + ; read_result <- readIface mod file_path hi_boot_file ; case read_result of Failed err -> returnM (Failed (badIfaceFile file_path err)) Succeeded iface - | mi_module iface /= mod_name -> - return (Failed (wrongIfaceModErr iface mod_name file_path)) + | mi_module iface /= mod -> + return (Failed (wrongIfaceModErr iface mod file_path)) | otherwise -> - returnM (Succeeded (iface{mi_package=pkg}, file_path)) + returnM (Succeeded (iface, file_path)) -- Don't forget to fill in the package name... }}} -findHiFile :: HscEnv -> Bool -> Module -> IsBootInterface - -> IO (MaybeErr FindResult (FilePath, PackageIdH)) -findHiFile hsc_env explicit mod_name hi_boot_file - = do { - -- In interactive or --make mode, we are *not allowed* to demand-load - -- a home package .hi file. So don't even look for them. - -- This helps in the case where you are sitting in eg. ghc/lib/std - -- and start up GHCi - it won't complain that all the modules it tries - -- to load are found in the home location. - let { home_allowed = isOneShot (ghcMode (hsc_dflags hsc_env)) } ; - maybe_found <- if home_allowed - then findModule hsc_env mod_name explicit - else findPackageModule hsc_env mod_name explicit; - - case maybe_found of - Found loc pkg -> return (Succeeded (path, pkg)) - where - path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) - - err -> return (Failed err) - } +findHiFile :: HscEnv -> Module -> IsBootInterface + -> IO (MaybeErr FindResult FilePath) +findHiFile hsc_env mod hi_boot_file + = do + maybe_found <- findExactModule hsc_env mod + case maybe_found of + Found loc mod -> return (Succeeded path) + where + path = addBootSuffix_maybe hi_boot_file (ml_hi_file loc) + err -> return (Failed err) \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: Module -> String -> IsBootInterface +readIface :: Module -> FilePath -> IsBootInterface -> TcRnIf gbl lcl (MaybeErr Message ModIface) -- Failed err <=> file not found, or unreadable, or illegible -- Succeeded iface <=> successfully found and parsed @@ -493,7 +483,7 @@ readIface wanted_mod file_path is_hi_boot_file initExternalPackageState :: ExternalPackageState initExternalPackageState = EPS { - eps_is_boot = emptyModuleEnv, + eps_is_boot = emptyUFM, eps_PIT = emptyPackageIfaceTable, eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, @@ -515,7 +505,7 @@ initExternalPackageState \begin{code} ghcPrimIface :: ModIface ghcPrimIface - = (emptyModIface HomePackage gHC_PRIM) { + = (emptyModIface gHC_PRIM) { mi_exports = [(gHC_PRIM, ghcPrimExports)], mi_decls = [], mi_fixities = fixities, @@ -563,7 +553,10 @@ badIfaceFile file err hiModuleNameMismatchWarn :: Module -> Module -> Message hiModuleNameMismatchWarn requested_mod read_mod = - hsep [ ptext SLIT("Something is amiss; requested module name") + withPprStyle defaultUserStyle $ + -- we want the Modules below to be qualified with package names, + -- so reset the PrintUnqualified setting. + hsep [ ptext SLIT("Something is amiss; requested module ") , ppr requested_mod , ptext SLIT("differs from name found in the interface file") , ppr read_mod diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 3ff30d9..b86aa92 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -176,7 +176,6 @@ compiled with -O. I think this is the case.] #include "HsVersions.h" import HsSyn -import Packages ( isHomeModule, PackageIdH(..) ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceRule(..), IfaceInst(..), IfaceExtName(..), eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool, @@ -199,7 +198,6 @@ import HscTypes ( ModIface(..), ModDetails(..), ) -import Packages ( HomeModules ) import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_HiVersion ) import Name ( Name, nameModule, nameOccName, nameParent, @@ -213,11 +211,7 @@ import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccSet, extendOccSetList, isEmptyOccSet, intersectOccSet, intersectsOccSet, occNameFS, isTcOcc ) -import Module ( Module, moduleFS, - ModLocation(..), mkModuleFS, moduleString, - ModuleEnv, emptyModuleEnv, lookupModuleEnv, - extendModuleEnv_C - ) +import Module import Outputable import Util ( createDirectoryHierarchy, directoryOf ) import Util ( sortLe, seqList ) @@ -227,6 +221,8 @@ import Unique ( Unique, Uniquable(..) ) import ErrUtils ( dumpIfSet_dyn, showPass ) import Digraph ( stronglyConnComp, SCC(..) ) import SrcLoc ( SrcSpan ) +import UniqFM +import PackageConfig ( PackageId ) import FiniteMap import FastString @@ -259,7 +255,6 @@ mkIface hsc_env maybe_old_iface mg_boot = is_boot, mg_usages = usages, mg_deps = deps, - mg_home_mods = home_mods, mg_rdr_env = rdr_env, mg_fix_env = fix_env, mg_deprecs = src_deprecs }) @@ -274,7 +269,7 @@ mkIface hsc_env maybe_old_iface -- to expose in the interface = do { eps <- hscEPS hsc_env - ; let { ext_nm_rhs = mkExtNameFn hsc_env home_mods eps this_mod + ; let { ext_nm_rhs = mkExtNameFn hsc_env eps this_mod ; ext_nm_lhs = mkLhsNameFn this_mod ; decls = [ tyThingToIfaceDecl ext_nm_rhs thing @@ -291,7 +286,6 @@ mkIface hsc_env maybe_old_iface ; intermediate_iface = ModIface { mi_module = this_mod, - mi_package = HomePackage, mi_boot = is_boot, mi_deps = deps, mi_usages = usages, @@ -346,8 +340,8 @@ writeIfaceFile location new_iface ----------------------------- -mkExtNameFn :: HscEnv -> HomeModules -> ExternalPackageState -> Module -> Name -> IfaceExtName -mkExtNameFn hsc_env hmods eps this_mod +mkExtNameFn :: HscEnv -> ExternalPackageState -> Module -> Name -> IfaceExtName +mkExtNameFn hsc_env eps this_mod = ext_nm where hpt = hsc_HPT hsc_env @@ -358,10 +352,15 @@ mkExtNameFn hsc_env hmods eps this_mod Nothing -> LocalTop occ Just par -> LocalTopSub occ (nameOccName par) | isWiredInName name = ExtPkg mod occ - | isHomeModule hmods mod = HomePkg mod occ vers + | 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 @@ -374,7 +373,7 @@ mkExtNameFn hsc_env hmods eps this_mod = mi_ver_fn iface occ `orElse` pprPanic "lookupVers1" (ppr mod <+> ppr occ) where - iface = lookupIfaceByModule hpt pit mod `orElse` + iface = lookupIfaceByModule (hsc_dflags hsc_env) hpt pit mod `orElse` pprPanic "lookupVers2" (ppr mod <+> ppr occ) @@ -636,24 +635,24 @@ bump_unless False v = bumpVersion v \begin{code} mkUsageInfo :: HscEnv - -> HomeModules -> ModuleEnv (Module, Bool, SrcSpan) - -> [(Module, IsBootInterface)] + -> [(ModuleName, IsBootInterface)] -> NameSet -> IO [Usage] -mkUsageInfo hsc_env hmods dir_imp_mods dep_mods used_names +mkUsageInfo hsc_env dir_imp_mods dep_mods used_names = do { eps <- hscEPS hsc_env - ; let usages = mk_usage_info (eps_PIT eps) hsc_env hmods + ; let usages = mk_usage_info (eps_PIT eps) hsc_env dir_imp_mods dep_mods used_names ; usages `seqList` return usages } -- seq the list of Usages returned: occasionally these -- 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 hmods dir_imp_mods dep_mods proto_used_names +mk_usage_info pit hsc_env dir_imp_mods dep_mods proto_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 @@ -682,28 +681,28 @@ mk_usage_info pit hsc_env hmods dir_imp_mods dep_mods proto_used_names -- (need to recompile if its export list changes: export_vers) -- c) is a home-package orphan module (need to recompile if its -- instance decls change: rules_vers) - mkUsage :: (Module, Bool) -> Maybe Usage + mkUsage :: (ModuleName, IsBootInterface) -> Maybe Usage mkUsage (mod_name, _) - | isNothing maybe_iface -- We can't depend on it if we didn't - || not (isHomeModule hmods mod) -- even open the interface! - || (null used_occs + | isNothing maybe_iface -- We can't depend on it if we didn't + || (null used_occs -- load its interface. && isNothing export_vers && not orphan_mod) = Nothing -- Record no usage info | otherwise - = Just (Usage { usg_name = mod, + = Just (Usage { usg_name = mod_name, usg_mod = mod_vers, usg_exports = export_vers, usg_entities = ent_vers, usg_rules = rules_vers }) where - maybe_iface = lookupIfaceByModule hpt pit mod_name + maybe_iface = lookupIfaceByModule dflags hpt pit mod -- In one-shot mode, the interfaces for home-package -- modules accumulate in the PIT not HPT. Sigh. + mod = mkModule (thisPackage dflags) mod_name + Just iface = maybe_iface - mod = mi_module iface orphan_mod = mi_orphan iface version_env = mi_ver_fn iface mod_vers = mi_mod_vers iface @@ -723,25 +722,25 @@ mkIfaceExports :: NameSet -> [(Module, [GenAvailInfo OccName])] -- Group by module and sort by occurrence -- This keeps the list in canonical order mkIfaceExports exports - = [ (mkModuleFS fs, eltsFM avails) - | (fs, avails) <- fmToList groupFM + = [ (mod, eltsUFM avails) + | (mod, avails) <- fmToList groupFM ] where - groupFM :: FiniteMap FastString (FiniteMap FastString (GenAvailInfo OccName)) + groupFM :: ModuleEnv (UniqFM (GenAvailInfo OccName)) -- Deliberately use the FastString so we -- get a canonical ordering - groupFM = foldl add emptyFM (nameSetToList exports) + groupFM = foldl add emptyModuleEnv (nameSetToList exports) - add env name = addToFM_C add_avail env mod_fs - (unitFM avail_fs avail) + add env name = extendModuleEnv_C add_avail env mod + (unitUFM avail_fs avail) where occ = nameOccName name - mod_fs = moduleFS (nameModule 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 _ = addToFM_C add_item avail_fm avail_fs 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) @@ -765,13 +764,14 @@ checkOldIface :: HscEnv checkOldIface hsc_env mod_summary source_unchanged maybe_iface = do { showPass (hsc_dflags hsc_env) - ("Checking old interface for " ++ moduleString (ms_mod mod_summary)) ; + ("Checking old interface for " ++ + showSDoc (ppr (ms_mod mod_summary))) ; ; initIfaceCheck hsc_env $ - check_old_iface mod_summary source_unchanged maybe_iface + check_old_iface hsc_env mod_summary source_unchanged maybe_iface } -check_old_iface mod_summary source_unchanged maybe_iface +check_old_iface hsc_env mod_summary source_unchanged maybe_iface = -- CHECK WHETHER THE SOURCE HAS CHANGED ifM (not source_unchanged) (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) @@ -786,9 +786,9 @@ check_old_iface mod_summary source_unchanged maybe_iface else case maybe_iface of { - Just old_iface -> -- Use the one we already have - checkVersions source_unchanged old_iface `thenM` \ recomp -> - returnM (recomp, Just old_iface) + Just old_iface -> do -- Use the one we already have + recomp <- checkVersions hsc_env source_unchanged old_iface + return (recomp, Just old_iface) ; Nothing -> @@ -807,7 +807,7 @@ check_old_iface mod_summary source_unchanged maybe_iface ; Succeeded iface -> -- We have got the old iface; check its versions - checkVersions source_unchanged iface `thenM` \ recomp -> + checkVersions hsc_env source_unchanged iface `thenM` \ recomp -> returnM (recomp, Just iface) }} \end{code} @@ -822,10 +822,11 @@ type RecompileRequired = Bool upToDate = False -- Recompile not required outOfDate = True -- Recompile required -checkVersions :: Bool -- True <=> source unchanged +checkVersions :: HscEnv + -> Bool -- True <=> source unchanged -> ModIface -- Old interface -> IfG RecompileRequired -checkVersions source_unchanged iface +checkVersions hsc_env source_unchanged iface | not source_unchanged = returnM outOfDate | otherwise @@ -844,29 +845,33 @@ checkVersions source_unchanged iface -- We do this regardless of compilation mode ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } - ; checkList [checkModUsage u | u <- mi_usages iface] + ; let this_pkg = thisPackage (hsc_dflags hsc_env) + ; checkList [checkModUsage this_pkg u | u <- mi_usages iface] } where -- This is a bit of a hack really - mod_deps :: ModuleEnv (Module, IsBootInterface) + mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface) mod_deps = mkModDeps (dep_mods (mi_deps iface)) -checkModUsage :: Usage -> IfG RecompileRequired +checkModUsage :: PackageId ->Usage -> IfG RecompileRequired -- Given the usage information extracted from the old -- M.hi file for the module being compiled, figure out -- whether M needs to be recompiled. -checkModUsage (Usage { usg_name = mod_name, usg_mod = old_mod_vers, - usg_rules = old_rule_vers, - usg_exports = maybe_old_export_vers, - usg_entities = old_decl_vers }) +checkModUsage this_pkg (Usage { usg_name = mod_name, usg_mod = old_mod_vers, + usg_rules = old_rule_vers, + usg_exports = maybe_old_export_vers, + usg_entities = old_decl_vers }) = -- Load the imported interface is possible let doc_str = sep [ptext SLIT("need version info for"), ppr mod_name] in traceHiDiffs (text "Checking usages for module" <+> ppr mod_name) `thenM_` - loadInterface doc_str mod_name ImportBySystem `thenM` \ mb_iface -> + let + mod = mkModule this_pkg mod_name + in + loadInterface doc_str mod ImportBySystem `thenM` \ mb_iface -> -- Load the interface, but don't complain on failure; -- Instead, get an Either back which we can test @@ -977,7 +982,6 @@ pprModIface :: ModIface -> SDoc -- Show a ModIface pprModIface iface = vcat [ ptext SLIT("interface") - <+> ppr_package (mi_package iface) <+> ppr (mi_module iface) <+> pp_boot <+> ppr (mi_mod_vers iface) <+> pp_sub_vers <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) @@ -995,8 +999,6 @@ pprModIface iface where pp_boot | mi_boot iface = ptext SLIT("[boot]") | otherwise = empty - ppr_package HomePackage = empty - ppr_package (ExtPackage id) = doubleQuotes (ppr id) exp_vers = mi_exp_vers iface rule_vers = mi_rule_vers iface diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 0b4df33..bd31cc0 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -53,7 +53,8 @@ import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, import NameEnv import OccName ( OccName, mkVarOccFS, mkTyVarOcc ) import FastString ( FastString ) -import Module ( Module, lookupModuleEnv ) +import Module ( Module, moduleName ) +import UniqFM ( lookupUFM ) import UniqSupply ( initUs_ ) import Outputable import ErrUtils ( Message ) @@ -246,7 +247,7 @@ tcHiBootIface mod -- And that's fine, because if M's ModInfo is in the HPT, then -- it's been compiled once, and we don't need to check the boot iface then do { hpt <- getHpt - ; case lookupModuleEnv hpt mod of + ; case lookupUFM hpt (moduleName mod) of Just info | mi_boot (hm_iface info) -> return (hm_details info) other -> return emptyModDetails } @@ -257,17 +258,16 @@ tcHiBootIface mod -- so eps_is_boot will record if any of our imports mention us by -- way of hi-boot file { eps <- getEps - ; case lookupModuleEnv (eps_is_boot eps) mod of { + ; case lookupUFM (eps_is_boot eps) (moduleName mod) of { Nothing -> return emptyModDetails ; -- The typical case Just (_, False) -> failWithTc moduleLoop ; -- Someone below us imported us! -- This is a loop with no hi-boot in the way - Just (mod, True) -> -- There's a hi-boot interface below us + Just (_mod, True) -> -- There's a hi-boot interface below us do { read_result <- findAndReadIface - True -- Explicit import? need mod True -- Hi-boot file @@ -843,7 +843,8 @@ tcIfaceGlobal name -- and its RULES are loaded too | otherwise = do { (eps,hpt) <- getEpsAndHpt - ; case lookupType hpt (eps_PTE eps) name of { + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of { Just thing -> return thing ; Nothing -> do diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index d1b2933..30f273e 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -27,6 +27,7 @@ import Finder ( mkStubPaths ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages +import PackageConfig ( rtsPackageId ) import Util import FastString ( unpackFS ) import Cmm ( Cmm ) @@ -35,7 +36,7 @@ import DynFlags import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable import Pretty ( Mode(..), printDoc ) -import Module ( Module, ModLocation(..) ) +import Module ( Module, ModLocation(..), moduleName ) import List ( nub ) import Maybes ( firstJust ) @@ -156,7 +157,7 @@ outputC dflags filenm mod location flat_absC hPutStrLn h ("#include \"" ++ (filenameOf stub_h) ++ "\"") writeCs dflags h flat_absC where - (_, stub_h) = mkStubPaths dflags mod location + (_, stub_h) = mkStubPaths dflags (moduleName mod) location \end{code} @@ -259,12 +260,9 @@ outputForeignStubs dflags mod location stubs "Foreign export header file" stub_h_output_d -- we need the #includes from the rts package for the stub files - let rtsid = rtsPackageId (pkgState dflags) - rts_includes - | ExtPackage pid <- rtsid = - let rts_pkg = getPackageDetails (pkgState dflags) pid in - concatMap mk_include (includes rts_pkg) - | otherwise = [] + let rts_includes = + let rts_pkg = getPackageDetails (pkgState dflags) rtsPackageId in + concatMap mk_include (includes rts_pkg) mk_include i = "#include \"" ++ i ++ "\"\n" stub_h_file_exists @@ -287,7 +285,7 @@ outputForeignStubs dflags mod location stubs return (stub_h_file_exists, stub_c_file_exists) where - (stub_c, stub_h) = mkStubPaths dflags mod location + (stub_c, stub_h) = mkStubPaths dflags (moduleName mod) location cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 80d906c..56f57f0 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -17,13 +17,12 @@ import GHC ( Session, ModSummary(..) ) import DynFlags ( DynFlags( verbosity, opt_dep ), getOpts ) import Util ( escapeSpaces, splitFilename, joinFileExt ) import HscTypes ( HscEnv, IsBootInterface, msObjFilePath, msHsFilePath ) -import Packages ( PackageIdH(..) ) import SysTools ( newTempName ) import qualified SysTools -import Module ( Module, ModLocation(..), mkModule, +import Module ( ModuleName, ModLocation(..), mkModuleName, addBootSuffix_maybe ) import Digraph ( SCC(..) ) -import Finder ( findModule, FindResult(..) ) +import Finder ( findImportedModule, FindResult(..) ) import Util ( global, consIORef ) import Outputable import Panic @@ -153,7 +152,7 @@ beginMkDependHS dflags = do ----------------------------------------------------------------- processDeps :: Session - -> [Module] + -> [ModuleName] -> Handle -- Write dependencies to here -> SCC ModSummary -> IO () @@ -217,24 +216,24 @@ processDeps session excl_mods hdl (AcyclicSCC node) findDependency :: HscEnv -> FilePath -- Importing module: used only for error msg - -> Module -- Imported module + -> ModuleName -- Imported module -> IsBootInterface -- Source import -> Bool -- Record dependency on package modules -> IO (Maybe FilePath) -- Interface file file findDependency hsc_env src imp is_boot include_pkg_deps = do { -- Find the module; this will be fast because -- we've done it once during downsweep - r <- findModule hsc_env imp True {-explicit-} + r <- findImportedModule hsc_env imp Nothing ; case r of - Found loc pkg - -- Not in this package: we don't need a dependency - | ExtPackage _ <- pkg, not include_pkg_deps - -> return Nothing - + Found loc mod -- Home package: just depend on the .hi or hi-boot file - | otherwise + | isJust (ml_hs_file loc) -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) + -- Not in this package: we don't need a dependency + | otherwise + -> return Nothing + _ -> panic "findDependency" } @@ -322,7 +321,7 @@ endMkDependHS dflags -- Flags GLOBAL_VAR(v_Dep_makefile, "Makefile", String); GLOBAL_VAR(v_Dep_include_pkg_deps, False, Bool); -GLOBAL_VAR(v_Dep_exclude_mods, [], [Module]); +GLOBAL_VAR(v_Dep_exclude_mods, [], [ModuleName]); GLOBAL_VAR(v_Dep_suffixes, [], [String]); GLOBAL_VAR(v_Dep_warnings, True, Bool); @@ -337,6 +336,6 @@ dep_opts = , ( "w", NoArg (writeIORef v_Dep_warnings False) ) , ( "-include-prelude", NoArg (writeIORef v_Dep_include_pkg_deps True) ) , ( "-include-pkg-deps", NoArg (writeIORef v_Dep_include_pkg_deps True) ) - , ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModule) ) - , ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModule) ) + , ( "-exclude-module=", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) ) + , ( "x", Prefix (consIORef v_Dep_exclude_mods . mkModuleName) ) ] diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs index a39ca38..800baf1 100644 --- a/compiler/main/DriverPipeline.hs +++ b/compiler/main/DriverPipeline.hs @@ -36,6 +36,7 @@ import Finder import HscTypes import Outputable import Module +import UniqFM ( eltsUFM ) import ErrUtils import DynFlags import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) ) @@ -235,7 +236,7 @@ compileStub dflags mod location = do stub_o = o_base ++ "_stub" `joinFileExt` o_ext -- compile the _stub.c file w/ gcc - let (stub_c,_) = mkStubPaths dflags mod location + let (stub_c,_) = mkStubPaths dflags (moduleName mod) location runPipeline StopLn dflags (stub_c,Nothing) (SpecificFile stub_o) Nothing{-no ModLocation-} @@ -271,7 +272,7 @@ link BatchCompile dflags batch_attempt_linking hpt | batch_attempt_linking = do let - home_mod_infos = moduleEnvElts hpt + home_mod_infos = eltsUFM hpt -- the packages we depend on pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos @@ -376,9 +377,7 @@ doLink dflags stop_phase o_files where -- Always link in the haskell98 package for static linking. Other -- packages have to be specified via the -package flag. - link_pkgs - | ExtPackage h98_id <- haskell98PackageId (pkgState dflags) = [h98_id] - | otherwise = [] + link_pkgs = [haskell98PackageId] -- --------------------------------------------------------------------------- @@ -640,7 +639,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma case src_flavour of ExtCoreFile -> do { -- no explicit imports in ExtCore input. ; m <- getCoreModuleName input_fn - ; return (Nothing, mkModule m) } + ; return (Nothing, mkModuleName m) } other -> do { buf <- hGetStringBuffer input_fn ; (_,_,L _ mod_name) <- getImports dflags buf input_fn @@ -677,22 +676,6 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma = location3 { ml_obj_file = ofile } | otherwise = location3 - -- Make the ModSummary to hand to hscMain - src_timestamp <- getModificationTime (basename `joinFileExt` suff) - let - unused_field = panic "runPhase:ModSummary field" - -- Some fields are not looked at by hscMain - mod_summary = ModSummary { ms_mod = mod_name, - ms_hsc_src = src_flavour, - ms_hspp_file = input_fn, - ms_hspp_opts = dflags, - ms_hspp_buf = hspp_buf, - ms_location = location4, - ms_hs_date = src_timestamp, - ms_obj_date = Nothing, - ms_imps = unused_field, - ms_srcimps = unused_field } - o_file = ml_obj_file location4 -- The real object file @@ -703,6 +686,8 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. + src_timestamp <- getModificationTime (basename `joinFileExt` suff) + let do_recomp = dopt Opt_RecompChecking dflags source_unchanged <- if not do_recomp || not (isStopLn stop) @@ -731,7 +716,22 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma hsc_env <- newHscEnv dflags' -- Tell the finder cache about this module - addHomeModuleToFinder hsc_env mod_name location4 + mod <- addHomeModuleToFinder hsc_env mod_name location4 + + -- Make the ModSummary to hand to hscMain + let + unused_field = panic "runPhase:ModSummary field" + -- Some fields are not looked at by hscMain + mod_summary = ModSummary { ms_mod = mod, + ms_hsc_src = src_flavour, + ms_hspp_file = input_fn, + ms_hspp_opts = dflags, + ms_hspp_buf = hspp_buf, + ms_location = location4, + ms_hs_date = src_timestamp, + ms_obj_date = Nothing, + ms_imps = unused_field, + ms_srcimps = unused_field } -- run the compiler! mbResult <- hscCompileOneShot hsc_env @@ -749,7 +749,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma return (StopLn, dflags', Just location4, o_file) Just (HscRecomp hasStub) -> do when hasStub $ - do stub_o <- compileStub dflags' mod_name location4 + do stub_o <- compileStub dflags' mod location4 consIORef v_Ld_inputs stub_o -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make @@ -1272,12 +1272,8 @@ doMkDLL dflags o_files dep_packages = do let extra_ld_opts = getOpts dflags opt_dll let pstate = pkgState dflags - rts_id | ExtPackage id <- rtsPackageId pstate = id - | otherwise = panic "staticLink: rts package missing" - base_id | ExtPackage id <- basePackageId pstate = id - | otherwise = panic "staticLink: base package missing" - rts_pkg = getPackageDetails pstate rts_id - base_pkg = getPackageDetails pstate base_id + rts_pkg = getPackageDetails pstate rtsPackageId + base_pkg = getPackageDetails pstate basePackageId let extra_os = if static || no_hs_main then [] diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 731ac29..bc6a0af 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -49,10 +49,14 @@ module DynFlags ( #include "HsVersions.h" -import Module ( Module, mkModule ) +import Module ( Module, mkModuleName, mkModule ) +import PackageConfig import PrelNames ( mAIN ) -import StaticFlags ( opt_Static, opt_PIC, - WayName(..), v_Ways, v_Build_tag, v_RTS_Build_tag ) +#ifdef i386_TARGET_ARCH +import StaticFlags ( opt_Static ) +#endif +import StaticFlags ( opt_PIC, WayName(..), v_Ways, v_Build_tag, + v_RTS_Build_tag ) import {-# SOURCE #-} Packages (PackageState) import DriverPhases ( Phase(..), phaseInputExt ) import Config @@ -210,6 +214,7 @@ data DynFlags = DynFlags { importPaths :: [FilePath], mainModIs :: Module, mainFunIs :: Maybe String, + thisPackage :: PackageId, -- ways wayNames :: [WayName], -- way flags from the cmd line @@ -344,6 +349,7 @@ defaultDynFlags = importPaths = ["."], mainModIs = mAIN, mainFunIs = Nothing, + thisPackage = mainPackageId, wayNames = panic "ways", buildTag = panic "buildTag", @@ -864,7 +870,7 @@ dynamic_flags = [ ------- Packages ---------------------------------------------------- , ( "package-conf" , HasArg extraPkgConf_ ) , ( "no-user-package-conf", NoArg (unSetDynFlag Opt_ReadUserPackageConf) ) - , ( "package-name" , HasArg ignorePackage ) -- for compatibility + , ( "package-name" , HasArg setPackageName ) , ( "package" , HasArg exposePackage ) , ( "hide-package" , HasArg hidePackage ) , ( "hide-all-packages", NoArg (setDynFlag Opt_HideAllPackages) ) @@ -1073,6 +1079,13 @@ hidePackage p = upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) +setPackageName p + | Nothing <- unpackPackageId pid + = throwDyn (CmdLineError ("cannot parse \'" ++ p ++ "\' as a package identifier")) + | otherwise + = upd (\s -> s{ thisPackage = pid }) + where + pid = stringToPackageId p -- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags -- (-fvia-C, -fasm, -filx respectively). @@ -1096,10 +1109,10 @@ setMainIs :: String -> DynP () setMainIs arg | not (null main_fn) -- The arg looked like "Foo.baz" = upd $ \d -> d{ mainFunIs = Just main_fn, - mainModIs = mkModule main_mod } + mainModIs = mkModule mainPackageId (mkModuleName main_mod) } | isUpper (head main_mod) -- The arg looked like "Foo" - = upd $ \d -> d{ mainModIs = mkModule main_mod } + = upd $ \d -> d{ mainModIs = mkModule mainPackageId (mkModuleName main_mod) } | otherwise -- The arg looked like "baz" = upd $ \d -> d{ mainFunIs = Just main_mod } diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index fbde40f..fd0982d 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -1,45 +1,47 @@ % -% (c) The University of Glasgow, 2000 +% (c) The University of Glasgow, 2000-2006 % \section[Finder]{Module Finder} \begin{code} module Finder ( - flushFinderCache, -- :: IO () + flushFinderCaches, FindResult(..), - findModule, -- :: ModuleName -> Bool -> IO FindResult - findPackageModule, -- :: ModuleName -> Bool -> IO FindResult - mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation - mkHomeModLocation2, -- :: ModuleName -> FilePath -> String -> IO ModLocation - addHomeModuleToFinder, -- :: HscEnv -> Module -> ModLocation -> IO () - uncacheModule, -- :: HscEnv -> Module -> IO () + findImportedModule, + findExactModule, + findHomeModule, + mkHomeModLocation, + mkHomeModLocation2, + addHomeModuleToFinder, + uncacheModule, mkStubPaths, findObjectLinkableMaybe, findObjectLinkable, - cantFindError, -- :: DynFlags -> Module -> FindResult -> SDoc + cantFindError, ) where #include "HsVersions.h" import Module -import UniqFM ( filterUFM, delFromUFM ) import HscTypes import Packages import FastString import Util +import PrelNames ( gHC_PRIM ) import DynFlags ( DynFlags(..), isOneShot, GhcMode(..) ) import Outputable +import FiniteMap +import UniqFM import Maybes ( expectJust ) -import DATA_IOREF ( IORef, writeIORef, readIORef ) +import DATA_IOREF ( IORef, writeIORef, readIORef, modifyIORef ) import Data.List import System.Directory import System.IO import Control.Monad -import Data.Maybe ( isNothing ) import Time ( ClockTime ) @@ -61,137 +63,174 @@ type BaseName = String -- Basename of file -- remove all the home modules from the cache; package modules are -- assumed to not move around during a session. -flushFinderCache :: IORef FinderCache -> IO () -flushFinderCache finder_cache = do - fm <- readIORef finder_cache - writeIORef finder_cache $! filterUFM (\(loc,m) -> isNothing m) fm - -addToFinderCache :: IORef FinderCache -> Module -> FinderCacheEntry -> IO () -addToFinderCache finder_cache mod_name entry = do - fm <- readIORef finder_cache - writeIORef finder_cache $! extendModuleEnv fm mod_name entry - -removeFromFinderCache :: IORef FinderCache -> Module -> IO () -removeFromFinderCache finder_cache mod_name = do - fm <- readIORef finder_cache - writeIORef finder_cache $! delFromUFM fm mod_name - -lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FinderCacheEntry) -lookupFinderCache finder_cache mod_name = do - fm <- readIORef finder_cache - return $! lookupModuleEnv fm mod_name +flushFinderCaches :: HscEnv -> IO () +flushFinderCaches hsc_env = do + writeIORef fc_ref emptyUFM + flushModLocationCache this_pkg mlc_ref + where + this_pkg = thisPackage (hsc_dflags hsc_env) + fc_ref = hsc_FC hsc_env + mlc_ref = hsc_MLC hsc_env + +flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO () +flushModLocationCache this_pkg ref = do + fm <- readIORef ref + writeIORef ref $! filterFM is_ext fm + return () + where is_ext mod _ | modulePackageId mod /= this_pkg = True + | otherwise = False + +addToFinderCache ref key val = modifyIORef ref $ \c -> addToUFM c key val +addToModLocationCache ref key val = modifyIORef ref $ \c -> addToFM c key val + +removeFromFinderCache ref key = modifyIORef ref $ \c -> delFromUFM c key +removeFromModLocationCache ref key = modifyIORef ref $ \c -> delFromFM c key + +lookupFinderCache ref key = do + c <- readIORef ref + return $! lookupUFM c key + +lookupModLocationCache ref key = do + c <- readIORef ref + return $! lookupFM c key -- ----------------------------------------------------------------------------- -- The two external entry points --- This is the main interface to the finder, which maps ModuleNames to --- Modules and ModLocations. --- --- The Module contains one crucial bit of information about a module: --- whether it lives in the current ("home") package or not (see Module --- for more details). --- --- The ModLocation contains the names of all the files associated with --- that module: its source file, .hi file, object file, etc. - -data FindResult - = Found ModLocation PackageIdH - -- the module was found - | FoundMultiple [PackageId] - -- *error*: both in multiple packages - | PackageHidden PackageId - -- for an explicit source import: the package containing the module is - -- not exposed. - | ModuleHidden PackageId - -- for an explicit source import: the package containing the module is - -- exposed, but the module itself is hidden. - | NotFound [FilePath] - -- the module was not found, the specified places were searched. - -findModule :: HscEnv -> Module -> Bool -> IO FindResult -findModule = findModule' True - -findPackageModule :: HscEnv -> Module -> Bool -> IO FindResult -findPackageModule = findModule' False - - -data LocalFindResult - = Ok FinderCacheEntry - | CantFindAmongst [FilePath] - | MultiplePackages [PackageId] - -findModule' :: Bool -> HscEnv -> Module -> Bool -> IO FindResult -findModule' home_allowed hsc_env name explicit - = do -- First try the cache - mb_entry <- lookupFinderCache cache name - case mb_entry of - Just old_entry -> return $! found old_entry - Nothing -> not_cached +-- | Locate a module that was imported by the user. We have the +-- module's name, and possibly a package name. Without a package +-- name, this function will use the search path and the known exposed +-- packages to find the module, if a package is specified then only +-- that package is searched for the module. + +findImportedModule :: HscEnv -> ModuleName -> Maybe PackageId -> IO FindResult +findImportedModule hsc_env mod_name mb_pkgid = + case mb_pkgid of + Nothing -> unqual_import + Just pkg | pkg == this_pkg -> home_import + | otherwise -> pkg_import pkg + where + dflags = hsc_dflags hsc_env + this_pkg = thisPackage dflags + + home_import = findHomeModule hsc_env mod_name + + pkg_import pkg = findPackageModule hsc_env (mkModule pkg mod_name) + -- ToDo: this isn't quite right, the module we want + -- might actually be in another package, but re-exposed + -- ToDo: should return NotFoundInPackage if + -- the module isn't exposed by the package. + + unqual_import = home_import + `orIfNotFound` + findExposedPackageModule hsc_env mod_name + +-- | Locate a specific 'Module'. The purpose of this function is to +-- create a 'ModLocation' for a given 'Module', that is to find out +-- where the files associated with this module live. It is used when +-- reading the interface for a module mentioned by another interface, +-- for example (a "system import"). + +findExactModule :: HscEnv -> Module -> IO FindResult +findExactModule hsc_env mod = + let dflags = hsc_dflags hsc_env in + if modulePackageId mod == thisPackage dflags + then findHomeModule hsc_env (moduleName mod) + else findPackageModule hsc_env mod - where - cache = hsc_FC hsc_env - dflags = hsc_dflags hsc_env - - -- We've found the module, so the remaining question is - -- whether it's visible or not - found :: FinderCacheEntry -> FindResult - found (loc, Nothing) - | home_allowed = Found loc HomePackage - | otherwise = NotFound [] - found (loc, Just (pkg, exposed_mod)) - | explicit && not exposed_mod = ModuleHidden pkg_name - | explicit && not (exposed pkg) = PackageHidden pkg_name - | otherwise = - Found loc (ExtPackage (mkPackageId (package pkg))) - where - pkg_name = packageConfigId pkg - - found_new entry = do - addToFinderCache cache name entry - return $! found entry - - not_cached - | not home_allowed = do - j <- findPackageModule' dflags name - case j of - Ok entry -> found_new entry - MultiplePackages pkgs -> return (FoundMultiple pkgs) - CantFindAmongst paths -> return (NotFound paths) - - | otherwise = do - j <- findHomeModule' dflags name - case j of - Ok entry -> found_new entry - MultiplePackages pkgs -> return (FoundMultiple pkgs) - CantFindAmongst home_files -> do - r <- findPackageModule' dflags name - case r of - CantFindAmongst pkg_files -> - return (NotFound (home_files ++ pkg_files)) - MultiplePackages pkgs -> - return (FoundMultiple pkgs) - Ok entry -> - found_new entry - -addHomeModuleToFinder :: HscEnv -> Module -> ModLocation -> IO () -addHomeModuleToFinder hsc_env mod loc - = addToFinderCache (hsc_FC hsc_env) mod (loc, Nothing) - -uncacheModule :: HscEnv -> Module -> IO () -uncacheModule hsc_env mod = removeFromFinderCache (hsc_FC hsc_env) mod +-- ----------------------------------------------------------------------------- +-- Helpers + +this `orIfNotFound` or_this = do + res <- this + case res of + NotFound here -> do + res2 <- or_this + case res2 of + NotFound or_here -> return (NotFound (here ++ or_here)) + _other -> return res2 + _other -> return res + + +homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult +homeSearchCache hsc_env mod_name do_this = do + m <- lookupFinderCache (hsc_FC hsc_env) mod_name + case m of + Just result -> return result + Nothing -> do + result <- do_this + addToFinderCache (hsc_FC hsc_env) mod_name result + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result + +findExposedPackageModule :: HscEnv -> ModuleName -> IO FindResult +findExposedPackageModule hsc_env mod_name + -- not found in any package: + | null found = return (NotFound []) + -- found in just one exposed package: + | [(pkg_conf, _)] <- found_exposed + = let pkgid = mkPackageId (package pkg_conf) in + findPackageModule_ hsc_env (mkModule pkgid mod_name) pkg_conf + -- not found in any exposed package, report how it was hidden: + | null found_exposed, ((pkg_conf, exposed_mod):_) <- found + = let pkgid = mkPackageId (package pkg_conf) in + if not (exposed_mod) + then return (ModuleHidden pkgid) + else return (PackageHidden pkgid) + | otherwise + = return (FoundMultiple (map (mkPackageId.package.fst) found_exposed)) + where + dflags = hsc_dflags hsc_env + found = lookupModuleInAllPackages dflags mod_name + found_exposed = filter is_exposed found + is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod + + +modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult +modLocationCache hsc_env mod do_this = do + mb_loc <- lookupModLocationCache mlc mod + case mb_loc of + Just loc -> return (Found loc mod) + Nothing -> do + result <- do_this + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result + where + mlc = hsc_MLC hsc_env + +addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module +addHomeModuleToFinder hsc_env mod_name loc = do + let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name + addToFinderCache (hsc_FC hsc_env) mod_name (Found loc mod) + addToModLocationCache (hsc_MLC hsc_env) mod loc + return mod + +uncacheModule :: HscEnv -> ModuleName -> IO () +uncacheModule hsc_env mod = do + let this_pkg = thisPackage (hsc_dflags hsc_env) + removeFromFinderCache (hsc_FC hsc_env) mod + removeFromModLocationCache (hsc_MLC hsc_env) (mkModule this_pkg mod) -- ----------------------------------------------------------------------------- -- The internal workers -findHomeModule' :: DynFlags -> Module -> IO LocalFindResult -findHomeModule' dflags mod = do - let home_path = importPaths dflags - hisuf = hiSuf dflags +-- | Search for a module in the home package only. +findHomeModule :: HscEnv -> ModuleName -> IO FindResult +findHomeModule hsc_env mod_name = + homeSearchCache hsc_env mod_name $ + let + dflags = hsc_dflags hsc_env + home_path = importPaths dflags + hisuf = hiSuf dflags + mod = mkModule (thisPackage dflags) mod_name - let source_exts = - [ ("hs", mkHomeModLocationSearched dflags mod "hs") - , ("lhs", mkHomeModLocationSearched dflags mod "lhs") + [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") + , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") ] hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) @@ -203,31 +242,43 @@ findHomeModule' dflags mod = do -- compilation mode we look for .hi and .hi-boot files only. exts | isOneShot (ghcMode dflags) = hi_exts | otherwise = source_exts - + in searchPathExts home_path mod exts - -findPackageModule' :: DynFlags -> Module -> IO LocalFindResult -findPackageModule' dflags mod - = case lookupModuleInAllPackages dflags mod of - [] -> return (CantFindAmongst []) - [pkg_info] -> findPackageIface dflags mod pkg_info - many -> return (MultiplePackages (map (mkPackageId.package.fst) many)) - -findPackageIface :: DynFlags -> Module -> (PackageConfig,Bool) -> IO LocalFindResult -findPackageIface dflags mod pkg_info@(pkg_conf, _) = do + + +-- | Search for a module in external packages only. +findPackageModule :: HscEnv -> Module -> IO FindResult +findPackageModule hsc_env mod = do let + dflags = hsc_dflags hsc_env + pkg_id = modulePackageId mod + pkg_map = pkgIdMap (pkgState dflags) + -- + case lookupPackage pkg_map pkg_id of + Nothing -> return (NoPackage pkg_id) + Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf + +findPackageModule_ hsc_env mod pkg_conf = + modLocationCache hsc_env mod $ + + -- special case for GHC.Prim; we won't find it in the filesystem. + if mod == gHC_PRIM + then return (Found (error "GHC.Prim ModLocation") mod) + else + + let + dflags = hsc_dflags hsc_env tag = buildTag dflags -- hi-suffix for packages depends on the build tag. package_hisuf | null tag = "hi" | otherwise = tag ++ "_hi" hi_exts = - [ (package_hisuf, - mkPackageModLocation dflags pkg_info package_hisuf) ] + [ (package_hisuf, mkHiOnlyModLocation dflags package_hisuf) ] source_exts = - [ ("hs", mkPackageModLocation dflags pkg_info package_hisuf) - , ("lhs", mkPackageModLocation dflags pkg_info package_hisuf) + [ ("hs", mkHiOnlyModLocation dflags package_hisuf) + , ("lhs", mkHiOnlyModLocation dflags package_hisuf) ] -- mkdependHS needs to look for source files in packages too, so @@ -238,7 +289,7 @@ findPackageIface dflags mod pkg_info@(pkg_conf, _) = do | otherwise = hi_exts -- we never look for a .hi-boot file in an external package; -- .hi-boot files only make sense for the home package. - + in searchPathExts (importDirs pkg_conf) mod exts -- ----------------------------------------------------------------------------- @@ -248,11 +299,11 @@ searchPathExts :: [FilePath] -- paths to search -> Module -- module name -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO FinderCacheEntry -- action + FileExt, -- suffix + FilePath -> BaseName -> IO ModLocation -- action ) ] - -> IO LocalFindResult + -> IO FindResult searchPathExts paths mod exts = do result <- search to_search @@ -267,9 +318,9 @@ searchPathExts paths mod exts return result where - basename = dots_to_slashes (moduleString mod) + basename = dots_to_slashes (moduleNameString (moduleName mod)) - to_search :: [(FilePath, IO FinderCacheEntry)] + to_search :: [(FilePath, IO ModLocation)] to_search = [ (file, fn path basename) | path <- paths, (ext,fn) <- exts, @@ -278,30 +329,17 @@ searchPathExts paths mod exts file = base `joinFileExt` ext ] - search [] = return (CantFindAmongst (map fst to_search)) + search [] = return (NotFound (map fst to_search)) search ((file, mk_result) : rest) = do b <- doesFileExist file if b - then do { res <- mk_result; return (Ok res) } + then do { loc <- mk_result; return (Found loc mod) } else search rest -mkHomeModLocationSearched :: DynFlags -> Module -> FileExt - -> FilePath -> BaseName -> IO FinderCacheEntry +mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt + -> FilePath -> BaseName -> IO ModLocation mkHomeModLocationSearched dflags mod suff path basename = do - loc <- mkHomeModLocation2 dflags mod (path `joinFileName` basename) suff - return (loc, Nothing) - -mkHiOnlyModLocation :: DynFlags -> FileExt -> FilePath -> BaseName - -> IO FinderCacheEntry -mkHiOnlyModLocation dflags hisuf path basename = do - loc <- hiOnlyModLocation dflags path basename hisuf - return (loc, Nothing) - -mkPackageModLocation :: DynFlags -> (PackageConfig, Bool) -> FileExt - -> FilePath -> BaseName -> IO FinderCacheEntry -mkPackageModLocation dflags pkg_info hisuf path basename = do - loc <- hiOnlyModLocation dflags path basename hisuf - return (loc, Just pkg_info) + mkHomeModLocation2 dflags mod (path `joinFileName` basename) suff -- ----------------------------------------------------------------------------- -- Constructing a home module location @@ -336,18 +374,18 @@ mkPackageModLocation dflags pkg_info hisuf path basename = do -- ext -- The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation :: DynFlags -> Module -> FilePath -> IO ModLocation +mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation mkHomeModLocation dflags mod src_filename = do let (basename,extension) = splitFilename src_filename mkHomeModLocation2 dflags mod basename extension mkHomeModLocation2 :: DynFlags - -> Module + -> ModuleName -> FilePath -- Of source module, without suffix -> String -- Suffix -> IO ModLocation mkHomeModLocation2 dflags mod src_basename ext = do - let mod_basename = dots_to_slashes (moduleString mod) + let mod_basename = dots_to_slashes (moduleNameString mod) obj_fn <- mkObjPath dflags src_basename mod_basename hi_fn <- mkHiPath dflags src_basename mod_basename @@ -356,8 +394,9 @@ mkHomeModLocation2 dflags mod src_basename ext = do ml_hi_file = hi_fn, ml_obj_file = obj_fn }) -hiOnlyModLocation :: DynFlags -> FilePath -> String -> Suffix -> IO ModLocation -hiOnlyModLocation dflags path basename hisuf +mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String + -> IO ModLocation +mkHiOnlyModLocation dflags hisuf path basename = do let full_basename = path `joinFileName` basename obj_fn <- mkObjPath dflags full_basename basename return ModLocation{ ml_hs_file = Nothing, @@ -412,7 +451,7 @@ mkHiPath dflags basename mod_basename mkStubPaths :: DynFlags - -> Module + -> ModuleName -> ModLocation -> (FilePath,FilePath) @@ -420,7 +459,7 @@ mkStubPaths dflags mod location = let stubdir = stubDir dflags - mod_basename = dots_to_slashes (moduleString mod) + mod_basename = dots_to_slashes (moduleNameString mod) src_basename = basenameOf (expectJust "mkStubPaths" (ml_hs_file location)) @@ -466,7 +505,7 @@ dots_to_slashes = map (\c -> if c == '.' then '/' else c) -- ----------------------------------------------------------------------------- -- Error messages -cantFindError :: DynFlags -> Module -> FindResult -> SDoc +cantFindError :: DynFlags -> ModuleName -> FindResult -> SDoc cantFindError dflags mod_name (FoundMultiple pkgs) = hang (ptext SLIT("Cannot import") <+> quotes (ppr mod_name) <> colon) 2 ( sep [ptext SLIT("it was found in multiple packages:"), @@ -486,6 +525,10 @@ cantFindError dflags mod_name find_result -> ptext SLIT("it is hidden") <+> parens (ptext SLIT("in package") <+> ppr pkg) + NoPackage pkg + -> ptext SLIT("no package matching") <+> ppr pkg <+> + ptext SLIT("was found") + NotFound files | null files -> ptext SLIT("it is not a module in the current program, or in any known package.") @@ -495,5 +538,8 @@ cantFindError dflags mod_name find_result -> hang (ptext SLIT("locations searched:")) 2 (vcat (map text files)) + NotFoundInPackage pkg + -> ptext SLIT("it is not in package") <+> ppr pkg + _ -> panic "cantFindErr" \end{code} diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 5f82cf3..543d2a9 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -43,7 +43,7 @@ module GHC ( TypecheckedSource, ParsedSource, RenamedSource, -- * Inspecting the module structure of the program - ModuleGraph, ModSummary(..), ModLocation(..), + ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..), getModuleGraph, isLoaded, topSortModuleGraph, @@ -65,6 +65,7 @@ module GHC ( -- * Interactive evaluation getBindings, getPrintUnqual, + findModule, #ifdef GHCI setContext, getContext, getNamesInScope, @@ -83,8 +84,12 @@ module GHC ( -- * Abstract syntax elements + -- ** Packages + PackageId, + -- ** Modules - Module, mkModule, pprModule, + Module, mkModule, pprModule, moduleName, modulePackageId, + ModuleName, mkModuleName, moduleNameString, -- ** Names Name, @@ -177,6 +182,7 @@ import RdrName ( plusGlobalRdrEnv, Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), mkGlobalRdrEnv ) import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType ) +import Name ( nameOccName ) import Type ( tidyType ) import VarEnv ( emptyTidyEnv ) import GHC.Exts ( unsafeCoerce# ) @@ -208,7 +214,7 @@ import DataCon ( DataCon, dataConWrapId, dataConSig, dataConTyCon, dataConFieldLabels, dataConStrictMarks, dataConIsInfix, isVanillaDataCon ) import Name ( Name, nameModule, NamedThing(..), nameParent_maybe, - nameSrcLoc, nameOccName ) + nameSrcLoc ) import OccName ( parenSymOcc ) import NameEnv ( nameEnvElts ) import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr ) @@ -216,19 +222,20 @@ import SrcLoc import DriverPipeline import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) import HeaderInfo ( getImports, getOptions ) -import Packages ( isHomePackage ) import Finder import HscMain ( newHscEnv, hscFileCheck, HscChecked(..) ) import HscTypes import DynFlags import SysTools ( initSysTools, cleanTempFiles ) import Module +import UniqFM +import PackageConfig ( PackageId ) import FiniteMap import Panic import Digraph import Bag ( unitBag ) import ErrUtils ( Severity(..), showPass, fatalErrorMsg, debugTraceMsg, - mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings ) + mkPlainErrMsg, printBagOfErrors ) import qualified ErrUtils import Util import StringBuffer ( StringBuffer, hGetStringBuffer ) @@ -448,7 +455,7 @@ guessTarget file Nothing if exists then return (Target (TargetFile lhs_file Nothing) Nothing) else do - return (Target (TargetModule (mkModule file)) Nothing) + return (Target (TargetModule (mkModuleName file)) Nothing) where hs_file = file `joinFileExt` "hs" lhs_file = file `joinFileExt` "lhs" @@ -483,7 +490,7 @@ setGlobalTypeScope session ids -- Perform a dependency analysis starting from the current targets -- and update the session with the new module graph. -depanal :: Session -> [Module] -> Bool -> IO (Maybe ModuleGraph) +depanal :: Session -> [ModuleName] -> Bool -> IO (Maybe ModuleGraph) depanal (Session ref) excluded_mods allow_dup_roots = do hsc_env <- readIORef ref let @@ -522,8 +529,8 @@ data ErrMsg = ErrMsg { data LoadHowMuch = LoadAllTargets - | LoadUpTo Module - | LoadDependenciesOf Module + | LoadUpTo ModuleName + | LoadDependenciesOf ModuleName -- | Try to load the program. If a Module is supplied, then just -- attempt to load up to this target. If no Module is supplied, @@ -552,10 +559,11 @@ load2 s@(Session ref) how_much mod_graph = do -- B.hs-boot in the module graph, but no B.hs -- The downsweep should have ensured this does not happen -- (see msDeps) - let all_home_mods = [ms_mod s | s <- mod_graph, not (isBootSummary s)] + let all_home_mods = [ms_mod_name s + | s <- mod_graph, not (isBootSummary s)] #ifdef DEBUG bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - not (ms_mod s `elem` all_home_mods)] + not (ms_mod_name s `elem` all_home_mods)] #endif ASSERT( null bad_boot_mods ) return () @@ -586,7 +594,7 @@ load2 s@(Session ref) how_much mod_graph = do -- Unload any modules which are going to be re-linked this time around. let stable_linkables = [ linkable | m <- stable_obj++stable_bco, - Just hmi <- [lookupModuleEnv pruned_hpt m], + Just hmi <- [lookupUFM pruned_hpt m], Just linkable <- [hm_linkable hmi] ] unload hsc_env stable_linkables @@ -623,7 +631,7 @@ load2 s@(Session ref) how_much mod_graph = do partial_mg | LoadDependenciesOf mod <- how_much = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod ms == mod; _ -> False ) + AcyclicSCC ms -> ms_mod_name ms == mod; _ -> False ) List.init partial_mg0 | otherwise = partial_mg0 @@ -631,9 +639,9 @@ load2 s@(Session ref) how_much mod_graph = do stable_mg = [ AcyclicSCC ms | AcyclicSCC ms <- full_mg, - ms_mod ms `elem` stable_obj++stable_bco, - ms_mod ms `notElem` [ ms_mod ms' | - AcyclicSCC ms' <- partial_mg ] ] + ms_mod_name ms `elem` stable_obj++stable_bco, + ms_mod_name ms `notElem` [ ms_mod_name ms' | + AcyclicSCC ms' <- partial_mg ] ] mg = stable_mg ++ partial_mg @@ -679,7 +687,7 @@ load2 s@(Session ref) how_much mod_graph = do when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $ debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++ "but no output will be generated\n" ++ - "because there is no " ++ moduleString main_mod ++ " module.")) + "because there is no " ++ moduleNameString (moduleName main_mod) ++ " module.")) -- link everything together linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1) @@ -701,7 +709,7 @@ load2 s@(Session ref) how_much mod_graph = do = filter ((`notElem` mods_to_zap_names).ms_mod) modsDone - let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep) + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) (hsc_HPT hsc_env1) -- Clean up after ourselves @@ -709,7 +717,7 @@ load2 s@(Session ref) how_much mod_graph = do -- there should be no Nothings where linkables should be, now ASSERT(all (isJust.hm_linkable) - (moduleEnvElts (hsc_HPT hsc_env))) do + (eltsUFM (hsc_HPT hsc_env))) do -- Link everything together linkresult <- link ghci_mode dflags False hpt4 @@ -780,7 +788,7 @@ type TypecheckedSource = LHsBinds Id -- for a module. 'checkModule' loads all the dependencies of the specified -- module in the Session, and then attempts to typecheck the module. If -- successful, it returns the abstract syntax for the module. -checkModule :: Session -> Module -> IO (Maybe CheckedModule) +checkModule :: Session -> ModuleName -> IO (Maybe CheckedModule) checkModule session@(Session ref) mod = do -- load up the dependencies first r <- load session (LoadDependenciesOf mod) @@ -789,7 +797,7 @@ checkModule session@(Session ref) mod = do -- now parse & typecheck the module hsc_env <- readIORef ref let mg = hsc_mod_graph hsc_env - case [ ms | ms <- mg, ms_mod ms == mod ] of + case [ ms | ms <- mg, ms_mod_name ms == mod ] of [] -> return Nothing (ms:_) -> do mbChecked <- hscFileCheck hsc_env{hsc_dflags=ms_hspp_opts ms} ms @@ -885,9 +893,9 @@ unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' checkStability :: HomePackageTable -- HPT from last compilation -> [SCC ModSummary] -- current module graph (cyclic) - -> [Module] -- all home modules - -> ([Module], -- stableObject - [Module]) -- stableBCO + -> [ModuleName] -- all home modules + -> ([ModuleName], -- stableObject + [ModuleName]) -- stableBCO checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs where @@ -897,7 +905,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs | otherwise = (stable_obj, stable_bco) where scc = flattenSCC scc0 - scc_mods = map ms_mod scc + scc_mods = map ms_mod_name scc home_module m = m `elem` all_home_mods && m `notElem` scc_mods scc_allimps = nub (filter home_module (concatMap ms_allimps scc)) @@ -919,7 +927,7 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs && same_as_prev t | otherwise = False where - same_as_prev t = case lookupModuleEnv hpt (ms_mod ms) of + same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of Just hmi | Just l <- hm_linkable hmi -> isObjectLinkable l && t == linkableTime l _other -> True @@ -931,13 +939,13 @@ checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs -- make's behaviour. bco_ok ms - = case lookupModuleEnv hpt (ms_mod ms) of + = case lookupUFM hpt (ms_mod_name ms) of Just hmi | Just l <- hm_linkable hmi -> not (isObjectLinkable l) && linkableTime l >= ms_hs_date ms _other -> False -ms_allimps :: ModSummary -> [Module] +ms_allimps :: ModSummary -> [ModuleName] ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms) -- ----------------------------------------------------------------------------- @@ -958,23 +966,23 @@ ms_allimps ms = map unLoc (ms_srcimps ms ++ ms_imps ms) pruneHomePackageTable :: HomePackageTable -> [ModSummary] - -> ([Module],[Module]) + -> ([ModuleName],[ModuleName]) -> HomePackageTable pruneHomePackageTable hpt summ (stable_obj, stable_bco) - = mapModuleEnv prune hpt + = mapUFM prune hpt where prune hmi | is_stable modl = hmi' | otherwise = hmi'{ hm_details = emptyModDetails } where - modl = mi_module (hm_iface hmi) + modl = moduleName (mi_module (hm_iface hmi)) hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms = hmi{ hm_linkable = Nothing } | otherwise = hmi - where ms = expectJust "prune" (lookupModuleEnv ms_map modl) + where ms = expectJust "prune" (lookupUFM ms_map modl) - ms_map = mkModuleEnv [(ms_mod ms, ms) | ms <- summ] + ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] is_stable m = m `elem` stable_obj || m `elem` stable_bco @@ -1011,7 +1019,7 @@ findPartiallyCompletedCycles modsDone theGraph upsweep :: HscEnv -- Includes initially-empty HPT -> HomePackageTable -- HPT from last time round (pruned) - -> ([Module],[Module]) -- stable modules (see checkStability) + -> ([ModuleName],[ModuleName]) -- stable modules (see checkStability) -> IO () -- How to clean up unwanted tmp files -> [SCC ModSummary] -- Mods to do (the worklist) -> IO (SuccessFlag, @@ -1044,11 +1052,10 @@ upsweep' hsc_env old_hpt stable_mods cleanup case mb_mod_info of Nothing -> return (Failed, hsc_env, []) Just mod_info -> do - { let this_mod = ms_mod mod + { let this_mod = ms_mod_name mod -- Add new info to hsc_env - hpt1 = extendModuleEnv (hsc_HPT hsc_env) - this_mod mod_info + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info hsc_env1 = hsc_env { hsc_HPT = hpt1 } -- Space-saving: delete the old HPT entry @@ -1058,7 +1065,7 @@ upsweep' hsc_env old_hpt stable_mods cleanup -- main Haskell source file. Deleting it -- would force .. (what?? --SDM) old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delModuleEnv old_hpt this_mod + | otherwise = delFromUFM old_hpt this_mod ; (restOK, hsc_env2, modOKs) <- upsweep' hsc_env1 old_hpt1 stable_mods cleanup @@ -1071,7 +1078,7 @@ upsweep' hsc_env old_hpt stable_mods cleanup -- successful. If no compilation happened, return the old Linkable. upsweep_mod :: HscEnv -> HomePackageTable - -> ([Module],[Module]) + -> ([ModuleName],[ModuleName]) -> ModSummary -> Int -- index of module -> Int -- total number of modules @@ -1080,13 +1087,14 @@ upsweep_mod :: HscEnv upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods = do let + this_mod_name = ms_mod_name summary this_mod = ms_mod summary mb_obj_date = ms_obj_date summary obj_fn = ml_obj_file (ms_location summary) hs_date = ms_hs_date summary compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo) - compile_it = upsweep_compile hsc_env old_hpt this_mod + compile_it = upsweep_compile hsc_env old_hpt this_mod_name summary mod_index nmods case ghcMode (hsc_dflags hsc_env) of @@ -1134,10 +1142,10 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods compile_it Nothing -- no existing code at all: we must recompile. where - is_stable_obj = this_mod `elem` stable_obj - is_stable_bco = this_mod `elem` stable_bco + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco - old_hmi = lookupModuleEnv old_hpt this_mod + old_hmi = lookupUFM old_hpt this_mod_name -- Run hsc to compile a module upsweep_compile hsc_env old_hpt this_mod summary @@ -1154,7 +1162,7 @@ upsweep_compile hsc_env old_hpt this_mod summary -- will always be recompiled mb_old_iface - = case lookupModuleEnv old_hpt this_mod of + = case lookupUFM old_hpt this_mod of Nothing -> Nothing Just hm_info | isBootSummary summary -> Just iface | not (mi_boot iface) -> Just iface @@ -1180,11 +1188,11 @@ upsweep_compile hsc_env old_hpt this_mod summary -- Filter modules in the HPT -retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable retainInTopLevelEnvs keep_these hpt - = mkModuleEnv [ (mod, expectJust "retain" mb_mod_info) + = listToUFM [ (mod, expectJust "retain" mb_mod_info) | mod <- keep_these - , let mb_mod_info = lookupModuleEnv hpt mod + , let mb_mod_info = lookupUFM hpt mod , isJust mb_mod_info ] -- --------------------------------------------------------------------------- @@ -1193,7 +1201,7 @@ retainInTopLevelEnvs keep_these hpt topSortModuleGraph :: Bool -- Drop hi-boot nodes? (see below) -> [ModSummary] - -> Maybe Module + -> Maybe ModuleName -> [SCC ModSummary] -- Calculate SCCs of the module graph, possibly dropping the hi-boot nodes -- The resulting list of strongly-connected-components is in topologically @@ -1226,7 +1234,7 @@ topSortModuleGraph drop_hs_boot_nodes summaries (Just mod) | otherwise = throwDyn (ProgramError "module does not exist") moduleGraphNodes :: Bool -> [ModSummary] - -> ([(ModSummary, Int, [Int])], HscSource -> Module -> Maybe Int) + -> ([(ModSummary, Int, [Int])], HscSource -> ModuleName -> Maybe Int) moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) where -- Drop hs-boot nodes by using HsSrcFile as the key @@ -1235,7 +1243,7 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) -- We use integers as the keys for the SCC algorithm nodes :: [(ModSummary, Int, [Int])] - nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod s)), + nodes = [(s, expectJust "topSort" (lookup_key (ms_hsc_src s) (ms_mod_name s)), out_edge_keys hs_boot_key (map unLoc (ms_srcimps s)) ++ out_edge_keys HsSrcFile (map unLoc (ms_imps s)) ) | s <- summaries @@ -1243,23 +1251,24 @@ moduleGraphNodes drop_hs_boot_nodes summaries = (nodes, lookup_key) -- Drop the hi-boot ones if told to do so key_map :: NodeMap Int - key_map = listToFM ([(ms_mod s, ms_hsc_src s) | s <- summaries] + key_map = listToFM ([(moduleName (ms_mod s), ms_hsc_src s) + | s <- summaries] `zip` [1..]) - lookup_key :: HscSource -> Module -> Maybe Int + lookup_key :: HscSource -> ModuleName -> Maybe Int lookup_key hs_src mod = lookupFM key_map (mod, hs_src) - out_edge_keys :: HscSource -> [Module] -> [Int] + out_edge_keys :: HscSource -> [ModuleName] -> [Int] out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms -- If we want keep_hi_boot_nodes, then we do lookup_key with -- the IsBootInterface parameter True; else False -type NodeKey = (Module, HscSource) -- The nodes of the graph are +type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are type NodeMap a = FiniteMap NodeKey a -- keyed by (mod, src_file_type) pairs msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (mod,boot) +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) mkNodeMap :: [ModSummary] -> NodeMap ModSummary mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] @@ -1267,6 +1276,9 @@ mkNodeMap summaries = listToFM [ (msKey s, s) | s <- summaries] nodeMapElts :: NodeMap a -> [a] nodeMapElts = eltsFM +ms_mod_name :: ModSummary -> ModuleName +ms_mod_name = moduleName . ms_mod + ----------------------------------------------------------------------------- -- Downsweep (dependency analysis) @@ -1284,7 +1296,7 @@ nodeMapElts = eltsFM downsweep :: HscEnv -> [ModSummary] -- Old summaries - -> [Module] -- Ignore dependencies on these; treat + -> [ModuleName] -- Ignore dependencies on these; treat -- them as if they were package modules -> Bool -- True <=> allow multiple targets to have -- the same module name; this is @@ -1336,7 +1348,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots dup_roots :: [[ModSummary]] -- Each at least of length 2 dup_roots = filterOut isSingleton (nodeMapElts root_map) - loop :: [(Located Module,IsBootInterface)] + loop :: [(Located ModuleName,IsBootInterface)] -- Work list: process these modules -> NodeMap [ModSummary] -- Visited set; the range is a list because @@ -1365,7 +1377,7 @@ mkRootMap :: [ModSummary] -> NodeMap [ModSummary] mkRootMap summaries = addListToFM_C (++) emptyFM [ (msKey s, [s]) | s <- summaries ] -msDeps :: ModSummary -> [(Located Module, IsBootInterface)] +msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] -- (msDeps s) returns the dependencies of the ModSummary s. -- A wrinkle is that for a {-# SOURCE #-} import we return -- *both* the hs-boot file @@ -1432,14 +1444,14 @@ summariseFile hsc_env old_summaries file mb_phase maybe_buf (dflags', hspp_fn, buf) <- preprocessFile dflags file mb_phase maybe_buf - (srcimps,the_imps, L _ mod) <- getImports dflags' buf hspp_fn + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn -- Make a ModLocation for this file - location <- mkHomeModLocation dflags mod file + location <- mkHomeModLocation dflags mod_name file -- Tell the Finder cache where it is, so that subsequent calls -- to findModule will find it, even if it's not on any search path - addHomeModuleToFinder hsc_env mod location + mod <- addHomeModuleToFinder hsc_env mod_name location src_timestamp <- case maybe_buf of Just (_,t) -> return t @@ -1469,9 +1481,9 @@ summariseModule :: HscEnv -> NodeMap ModSummary -- Map of old summaries -> IsBootInterface -- True <=> a {-# SOURCE #-} import - -> Located Module -- Imported module to be summarised + -> Located ModuleName -- Imported module to be summarised -> Maybe (StringBuffer, ClockTime) - -> [Module] -- Modules to exclude + -> [ModuleName] -- Modules to exclude -> IO (Maybe ModSummary) -- Its new summary summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf excl_mods @@ -1508,9 +1520,8 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc obj_timestamp <- getObjTimestamp location is_boot return (Just old_summary{ ms_obj_date = obj_timestamp }) | otherwise = - -- source changed: find and re-summarise. We call the finder - -- again, because the user may have moved the source file. - new_summary location src_fn src_timestamp + -- source changed: re-summarise. + new_summary location (ms_mod old_summary) src_fn src_timestamp find_it = do -- Don't use the Finder's cache this time. If the module was @@ -1518,17 +1529,22 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- search path, so we want to consider it to be a home module. If -- the module was previously a home module, it may have moved. uncacheModule hsc_env wanted_mod - found <- findModule hsc_env wanted_mod True {-explicit-} + found <- findImportedModule hsc_env wanted_mod Nothing case found of - Found location pkg - | not (isHomePackage pkg) -> return Nothing - -- Drop external-pkg - | isJust (ml_hs_file location) -> just_found location + Found location mod + | isJust (ml_hs_file location) -> -- Home package + just_found location mod + | otherwise -> + -- Drop external-pkg + ASSERT(modulePackageId mod /= thisPackage dflags) + return Nothing + where + err -> noModError dflags loc wanted_mod err -- Not found - just_found location = do + just_found location mod = do -- Adjust location to point to the hs-boot source file, -- hi file, object file, when is_boot says so let location' | is_boot = addBootSuffixLocn location @@ -1540,10 +1556,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc maybe_t <- modificationTimeIfExists src_fn case maybe_t of Nothing -> noHsFileErr loc src_fn - Just t -> new_summary location' src_fn t + Just t -> new_summary location' mod src_fn t - new_summary location src_fn src_timestamp + new_summary location mod src_fn src_timestamp = do -- Preprocess the source file and get its imports -- The dflags' contains the OPTIONS pragmas @@ -1558,7 +1574,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) maybe_buf exc -- Find the object timestamp, and return the summary obj_timestamp <- getObjTimestamp location is_boot - return (Just ( ModSummary { ms_mod = wanted_mod, + return (Just ( ModSummary { ms_mod = mod, ms_hsc_src = hsc_src, ms_location = location, ms_hspp_file = hspp_fn, @@ -1610,7 +1626,7 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time)) -- Error messages ----------------------------------------------------------------------------- -noModError :: DynFlags -> SrcSpan -> Module -> FindResult -> IO ab +noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab -- ToDo: we don't have a proper line number for this error noModError dflags loc wanted_mod err = throwDyn $ mkPlainErrMsg loc $ cantFindError dflags wanted_mod err @@ -1650,8 +1666,7 @@ cyclicModuleErr ms -- Note: if you change the working directory, you should also unload -- the current program (set targets to empty, followed by load). workingDirectoryChanged :: Session -> IO () -workingDirectoryChanged s = withSession s $ \hsc_env -> - flushFinderCache (hsc_FC hsc_env) +workingDirectoryChanged s = withSession s $ flushFinderCaches -- ----------------------------------------------------------------------------- -- inspecting the session @@ -1660,9 +1675,9 @@ workingDirectoryChanged s = withSession s $ \hsc_env -> getModuleGraph :: Session -> IO ModuleGraph -- ToDo: DiGraph ModSummary getModuleGraph s = withSession s (return . hsc_mod_graph) -isLoaded :: Session -> Module -> IO Bool +isLoaded :: Session -> ModuleName -> IO Bool isLoaded s m = withSession s $ \hsc_env -> - return $! isJust (lookupModuleEnv (hsc_HPT hsc_env) m) + return $! isJust (lookupUFM (hsc_HPT hsc_env) m) getBindings :: Session -> IO [TyThing] getBindings s = withSession s (return . nameEnvElts . ic_type_env . hsc_IC) @@ -1686,7 +1701,7 @@ getModuleInfo :: Session -> Module -> IO (Maybe ModuleInfo) getModuleInfo s mdl = withSession s $ \hsc_env -> do let mg = hsc_mod_graph hsc_env if mdl `elem` map ms_mod mg - then getHomeModuleInfo hsc_env mdl + then getHomeModuleInfo hsc_env (moduleName mdl) else do {- if isHomeModule (hsc_dflags hsc_env) mdl then return Nothing @@ -1713,7 +1728,7 @@ getPackageModuleInfo hsc_env mdl = do return (Just (ModuleInfo { minf_type_env = mkTypeEnv tys, minf_exports = names, - minf_rdr_env = Just $! nameSetToGlobalRdrEnv names mdl, + minf_rdr_env = Just $! nameSetToGlobalRdrEnv names (moduleName mdl), minf_instances = error "getModuleInfo: instances for package module unimplemented" })) #else @@ -1722,7 +1737,7 @@ getPackageModuleInfo hsc_env mdl = do #endif getHomeModuleInfo hsc_env mdl = - case lookupModuleEnv (hsc_HPT hsc_env) mdl of + case lookupUFM (hsc_HPT hsc_env) mdl of Nothing -> return Nothing Just hmi -> do let details = hm_details hmi @@ -1753,7 +1768,7 @@ modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (minf_exports minf) modInfoPrintUnqualified :: ModuleInfo -> Maybe PrintUnqualified -modInfoPrintUnqualified minf = fmap unQualInScope (minf_rdr_env minf) +modInfoPrintUnqualified minf = fmap mkPrintUnqualified (minf_rdr_env minf) modInfoLookupName :: Session -> ModuleInfo -> Name -> IO (Maybe TyThing) modInfoLookupName s minf name = withSession s $ \hsc_env -> do @@ -1761,7 +1776,8 @@ modInfoLookupName s minf name = withSession s $ \hsc_env -> do Just tyThing -> return (Just tyThing) Nothing -> do eps <- readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + return $! lookupType (hsc_dflags hsc_env) + (hsc_HPT hsc_env) (eps_PTE eps) name isDictonaryId :: Id -> Bool isDictonaryId id @@ -1774,7 +1790,8 @@ isDictonaryId id lookupGlobalName :: Session -> Name -> IO (Maybe TyThing) lookupGlobalName s name = withSession s $ \hsc_env -> do eps <- readIORef (hsc_EPS hsc_env) - return $! lookupType (hsc_HPT hsc_env) (eps_PTE eps) name + return $! lookupType (hsc_dflags hsc_env) + (hsc_HPT hsc_env) (eps_PTE eps) name -- ----------------------------------------------------------------------------- -- Misc exported utils @@ -1811,6 +1828,29 @@ getTokenStream :: Session -> Module -> IO [Located Token] -- ----------------------------------------------------------------------------- -- Interactive evaluation +-- | Takes a 'ModuleName' and possibly a 'PackageId', and consults the +-- filesystem and package database to find the corresponding 'Module', +-- using the algorithm that is used for an @import@ declaration. +findModule :: Session -> ModuleName -> Maybe PackageId -> IO Module +findModule s mod_name maybe_pkg = withSession s $ \hsc_env -> + findModule' hsc_env mod_name maybe_pkg + +findModule' hsc_env mod_name maybe_pkg = + let + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + this_pkg = thisPackage dflags + in + case lookupUFM hpt mod_name of + Just mod_info -> return (mi_module (hm_iface mod_info)) + _not_a_home_module -> do + res <- findImportedModule hsc_env mod_name Nothing + case res of + Found _ m | modulePackageId m /= this_pkg -> return m + -- not allowed to be a home module + err -> let msg = cantFindError dflags mod_name err in + throwDyn (CmdLineError (showSDoc msg)) + #ifdef GHCI -- | Set the interactive evaluation context. @@ -1822,17 +1862,16 @@ setContext :: Session -> [Module] -- entire top level scope of these modules -> [Module] -- exports only of these modules -> IO () -setContext (Session ref) toplevs exports = do +setContext (Session ref) toplev_mods export_mods = do hsc_env <- readIORef ref let old_ic = hsc_IC hsc_env hpt = hsc_HPT hsc_env - - mapM_ (checkModuleExists hsc_env hpt) exports - export_env <- mkExportEnv hsc_env exports - toplev_envs <- mapM (mkTopLevEnv hpt) toplevs + -- + export_env <- mkExportEnv hsc_env export_mods + toplev_envs <- mapM (mkTopLevEnv hpt) toplev_mods let all_env = foldr plusGlobalRdrEnv export_env toplev_envs - writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplevs, - ic_exports = exports, + writeIORef ref hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, + ic_exports = export_mods, ic_rn_gbl_env = all_env }} @@ -1842,47 +1881,35 @@ mkExportEnv hsc_env mods = do stuff <- mapM (getModuleExports hsc_env) mods let (_msgs, mb_name_sets) = unzip stuff - gres = [ nameSetToGlobalRdrEnv name_set mod + gres = [ nameSetToGlobalRdrEnv name_set (moduleName mod) | (Just name_set, mod) <- zip mb_name_sets mods ] -- return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv gres -nameSetToGlobalRdrEnv :: NameSet -> Module -> GlobalRdrEnv +nameSetToGlobalRdrEnv :: NameSet -> ModuleName -> GlobalRdrEnv nameSetToGlobalRdrEnv names mod = mkGlobalRdrEnv [ GRE { gre_name = name, gre_prov = vanillaProv mod } | name <- nameSetToList names ] -vanillaProv :: Module -> Provenance +vanillaProv :: ModuleName -> Provenance -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module -vanillaProv mod = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] +vanillaProv mod_name = Imported [ImpSpec { is_decl = decl, is_item = ImpAll}] where - decl = ImpDeclSpec { is_mod = mod, is_as = mod, + decl = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = srcLocSpan interactiveSrcLoc } -checkModuleExists :: HscEnv -> HomePackageTable -> Module -> IO () -checkModuleExists hsc_env hpt mod = - case lookupModuleEnv hpt mod of - Just mod_info -> return () - _not_a_home_module -> do - res <- findPackageModule hsc_env mod True - case res of - Found _ _ -> return () - err -> let msg = cantFindError (hsc_dflags hsc_env) mod err in - throwDyn (CmdLineError (showSDoc msg)) - mkTopLevEnv :: HomePackageTable -> Module -> IO GlobalRdrEnv mkTopLevEnv hpt modl - = case lookupModuleEnv hpt modl of - Nothing -> - throwDyn (ProgramError ("mkTopLevEnv: not a home module " - ++ showSDoc (pprModule modl))) + = case lookupUFM hpt (moduleName modl) of + Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ + showSDoc (ppr modl))) Just details -> case mi_globals (hm_iface details) of Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not interpreted " - ++ showSDoc (pprModule modl))) + ++ showSDoc (ppr modl))) Just env -> return env -- | Get the interactive evaluation context, consisting of a pair of the @@ -1896,9 +1923,11 @@ getContext s = withSession s (\HscEnv{ hsc_IC=ic } -> -- its full top-level scope available. moduleIsInterpreted :: Session -> Module -> IO Bool moduleIsInterpreted s modl = withSession s $ \h -> - case lookupModuleEnv (hsc_HPT h) modl of - Just details -> return (isJust (mi_globals (hm_iface details))) - _not_a_home_module -> return False + if modulePackageId modl /= thisPackage (hsc_dflags h) + then return False + else case lookupUFM (hsc_HPT h) (moduleName modl) of + Just details -> return (isJust (mi_globals (hm_iface details))) + _not_a_home_module -> return False -- | Looks up an identifier in the current interactive context (for :info) getInfo :: Session -> Name -> IO (Maybe (TyThing,Fixity,[Instance])) @@ -2076,7 +2105,7 @@ foreign import "rts_evalStableIO" {- safe -} showModule :: Session -> ModSummary -> IO String showModule s mod_summary = withSession s $ \hsc_env -> do - case lookupModuleEnv (hsc_HPT hsc_env) (ms_mod mod_summary) of + case lookupUFM (hsc_HPT hsc_env) (ms_mod_name mod_summary) of Nothing -> panic "missing linkable" Just mod_info -> return (showModMsg (hscTarget (hsc_dflags hsc_env)) (not obj_linkable) mod_summary) where diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs index 913ac33..847d193 100644 --- a/compiler/main/HeaderInfo.hs +++ b/compiler/main/HeaderInfo.hs @@ -19,8 +19,8 @@ import Lexer ( P(..), ParseResult(..), mkPState, pragState , lexer, Token(..), PState(..) ) import FastString import HsSyn ( ImportDecl(..), HsModule(..) ) -import Module ( Module, mkModule ) -import PrelNames ( gHC_PRIM ) +import Module ( ModuleName, moduleName ) +import PrelNames ( gHC_PRIM, mAIN_NAME ) import StringBuffer ( StringBuffer(..), hGetStringBuffer, hGetStringBufferBlock , appendStringBuffers ) import SrcLoc ( Located(..), mkSrcLoc, unLoc, noSrcSpan ) @@ -31,12 +31,10 @@ import Util import Outputable import Pretty () import Panic -import Bag ( unitBag, emptyBag, listToBag ) +import Bag ( emptyBag, listToBag ) import Distribution.Compiler -import TRACE - import EXCEPTION ( throwDyn ) import IO import List @@ -55,13 +53,13 @@ openBinaryFile fp mode = openFileEx fp (BinaryMode mode) -- we can end up with a large number of open handles before the garbage -- collector gets around to closing them. getImportsFromFile :: DynFlags -> FilePath - -> IO ([Located Module], [Located Module], Located Module) + -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName) getImportsFromFile dflags filename = do buf <- hGetStringBuffer filename getImports dflags buf filename getImports :: DynFlags -> StringBuffer -> FilePath - -> IO ([Located Module], [Located Module], Located Module) + -> IO ([Located ModuleName], [Located ModuleName], Located ModuleName) getImports dflags buf filename = do let loc = mkSrcLoc (mkFastString filename) 1 0 case unP parseHeader (mkPState buf loc dflags) of @@ -71,10 +69,10 @@ getImports dflags buf filename = do L _ (HsModule mod _ imps _ _) -> let mod_name | Just located_mod <- mod = located_mod - | otherwise = L noSrcSpan (mkModule "Main") + | otherwise = L noSrcSpan mAIN_NAME (src_idecls, ord_idecls) = partition isSourceIdecl (map unLoc imps) source_imps = map getImpMod src_idecls - ordinary_imps = filter ((/= gHC_PRIM) . unLoc) + ordinary_imps = filter ((/= moduleName gHC_PRIM) . unLoc) (map getImpMod ord_idecls) -- GHC.Prim doesn't exist physically, so don't go looking for it. in diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 1823910..e5b7026 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -68,7 +68,6 @@ import TidyPgm ( tidyProgram, mkBootModDetails ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) import TyCon ( isDataTyCon ) -import Packages ( mkHomeModules ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) @@ -87,7 +86,7 @@ import MkExternalCore ( emitExternalCore ) import ParserCore import ParserCoreUtils import FastString -import Maybes ( expectJust ) +import UniqFM ( emptyUFM ) import Bag ( unitBag ) import Monad ( unless ) import IO @@ -107,7 +106,8 @@ newHscEnv dflags = do { eps_var <- newIORef initExternalPackageState ; us <- mkSplitUniqSupply 'r' ; nc_var <- newIORef (initNameCache us knownKeyNames) - ; fc_var <- newIORef emptyModuleEnv + ; fc_var <- newIORef emptyUFM + ; mlc_var <- newIORef emptyModuleEnv ; return (HscEnv { hsc_dflags = dflags, hsc_targets = [], hsc_mod_graph = [], @@ -116,6 +116,7 @@ newHscEnv dflags hsc_EPS = eps_var, hsc_NC = nc_var, hsc_FC = fc_var, + hsc_MLC = mlc_var, hsc_global_rdr_env = emptyGlobalRdrEnv, hsc_global_type_env = emptyNameEnv } ) } @@ -579,7 +580,6 @@ hscCompile cgguts cg_tycons = tycons, cg_dir_imps = dir_imps, cg_foreign = foreign_stubs, - cg_home_mods = home_mods, cg_dep_pkgs = dependencies } = cgguts dflags = hsc_dflags hsc_env location = ms_location mod_summary @@ -595,10 +595,10 @@ hscCompile cgguts ----------------- Convert to STG ------------------ (stg_binds, cost_centre_info) <- {-# SCC "CoreToStg" #-} - myCoreToStg dflags home_mods this_mod prepd_binds + myCoreToStg dflags this_mod prepd_binds ------------------ Code generation ------------------ abstractC <- {-# SCC "CodeGen" #-} - codeGen dflags home_mods this_mod data_tycons + codeGen dflags this_mod data_tycons foreign_stubs dir_imps cost_centre_info stg_binds ------------------ Code output ----------------------- @@ -696,7 +696,7 @@ hscFileCheck hsc_env mod_summary = do { hscCmmFile :: DynFlags -> FilePath -> IO Bool hscCmmFile dflags filename = do - maybe_cmm <- parseCmmFile dflags (mkHomeModules []) filename + maybe_cmm <- parseCmmFile dflags filename case maybe_cmm of Nothing -> return False Just cmm -> do @@ -739,13 +739,13 @@ myParseModule dflags src_filename maybe_src_buf }} -myCoreToStg dflags home_mods this_mod prepd_binds +myCoreToStg dflags this_mod prepd_binds = do stg_binds <- {-# SCC "Core2Stg" #-} - coreToStg home_mods prepd_binds + coreToStg (thisPackage dflags) prepd_binds (stg_binds2, cost_centre_info) <- {-# SCC "Stg2Stg" #-} - stg2stg dflags home_mods this_mod stg_binds + stg2stg dflags this_mod stg_binds return (stg_binds2, cost_centre_info) \end{code} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index e67de3b..a200bf9 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -7,7 +7,7 @@ module HscTypes ( -- * Sessions and compilation state Session(..), HscEnv(..), hscEPS, - FinderCache, FinderCacheEntry, + FinderCache, FindResult(..), ModLocationCache, Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, @@ -24,10 +24,10 @@ module HscTypes ( ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, - lookupIface, lookupIfaceByModule, emptyModIface, + lookupIfaceByModule, emptyModIface, InteractiveContext(..), emptyInteractiveContext, - icPrintUnqual, unQualInScope, + icPrintUnqual, mkPrintUnqualified, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, emptyIfaceDepCache, @@ -67,8 +67,9 @@ import ByteCodeAsm ( CompiledByteCode ) #endif import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, - LocalRdrEnv, emptyLocalRdrEnv, - GlobalRdrElt(..), mkRdrUnqual, lookupGRE_RdrName ) + LocalRdrEnv, emptyLocalRdrEnv, GlobalRdrElt(..), + unQualOK, ImpDeclSpec(..), Provenance(..), + ImportSpec(..), lookupGlobalRdrEnv ) import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet @@ -85,7 +86,7 @@ import Class ( Class, classSelIds, classTyCon ) import TyCon ( TyCon, tyConSelIds, tyConDataCons ) import DataCon ( dataConImplicitIds ) import PrelNames ( gHC_PRIM ) -import Packages ( PackageIdH, PackageId, PackageConfig, HomeModules ) +import Packages ( PackageId ) import DynFlags ( DynFlags(..), isOneShot, HscTarget (..) ) import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( Version, initialVersion, IPName, @@ -98,6 +99,7 @@ import CoreSyn ( CoreRule ) import Maybes ( orElse, expectJust ) import Outputable import SrcLoc ( SrcSpan, Located ) +import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString ( FastString ) @@ -172,9 +174,11 @@ data HscEnv -- sucking in interface files. They cache the state of -- external interface files, in effect. - hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), + hsc_FC :: {-# UNPACK #-} !(IORef FinderCache), + hsc_MLC :: {-# UNPACK #-} !(IORef ModLocationCache), -- The finder's cache. This caches the location of modules, -- so we don't have to search the filesystem multiple times. + hsc_global_rdr_env :: GlobalRdrEnv, hsc_global_type_env :: TypeEnv } @@ -191,7 +195,7 @@ hscEPS hsc_env = readIORef (hsc_EPS hsc_env) data Target = Target TargetId (Maybe (StringBuffer,ClockTime)) data TargetId - = TargetModule Module + = TargetModule ModuleName -- ^ A module name: search for the file | TargetFile FilePath (Maybe Phase) -- ^ A filename: preprocess & parse it to find the module name. @@ -206,16 +210,13 @@ pprTarget (Target id _) = pprTargetId id pprTargetId (TargetModule m) = ppr m pprTargetId (TargetFile f _) = text f -type FinderCache = ModuleEnv FinderCacheEntry -type FinderCacheEntry = (ModLocation, Maybe (PackageConfig,Bool)) - -- The finder's cache (see module Finder) - -type HomePackageTable = ModuleEnv HomeModInfo +type HomePackageTable = ModuleNameEnv HomeModInfo -- Domain = modules in the home package + -- "home" package name cached here for convenience type PackageIfaceTable = ModuleEnv ModIface -- Domain = modules in the imported packages -emptyHomePackageTable = emptyModuleEnv +emptyHomePackageTable = emptyUFM emptyPackageIfaceTable = emptyModuleEnv data HomeModInfo @@ -232,40 +233,37 @@ data HomeModInfo -- When re-linking a module (hscNoRecomp), we construct -- the HomModInfo by building a new ModDetails from the -- old ModIface (only). -\end{code} -Simple lookups in the symbol table. - -\begin{code} -lookupIface :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface --- We often have two IfaceTables, and want to do a lookup -lookupIface hpt pit mod - = case lookupModuleEnv hpt mod of - Just mod_info -> Just (hm_iface mod_info) - Nothing -> lookupModuleEnv pit mod - -lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface --- We often have two IfaceTables, and want to do a lookup -lookupIfaceByModule hpt pit mod - = case lookupModuleEnv hpt mod of - Just mod_info -> Just (hm_iface mod_info) - Nothing -> lookupModuleEnv pit mod +-- | Find the 'ModIface' for a 'Module' +lookupIfaceByModule + :: DynFlags + -> HomePackageTable + -> PackageIfaceTable + -> Module + -> Maybe ModIface +lookupIfaceByModule dflags hpt pit mod + -- in one-shot, we don't use the HPT + | not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg + = fmap hm_iface (lookupUFM hpt (moduleName mod)) + | otherwise + = lookupModuleEnv pit mod + where this_pkg = thisPackage dflags \end{code} \begin{code} -hptInstances :: HscEnv -> (Module -> Bool) -> [Instance] +hptInstances :: HscEnv -> (ModuleName -> Bool) -> [Instance] -- Find all the instance declarations that are in modules imported -- by this one, directly or indirectly, and are in the Home Package Table -- This ensures that we don't see instances from modules --make compiled -- before this one, but which are not below this one hptInstances hsc_env want_this_module = [ ispec - | mod_info <- moduleEnvElts (hsc_HPT hsc_env) - , want_this_module (mi_module (hm_iface mod_info)) + | mod_info <- eltsUFM (hsc_HPT hsc_env) + , want_this_module (moduleName (mi_module (hm_iface mod_info))) , ispec <- md_insts (hm_details mod_info) ] -hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [CoreRule] +hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] -- Get rules from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances hptRules hsc_env deps @@ -283,10 +281,10 @@ hptRules hsc_env deps -- be in the HPT, because we never compile it; it's in the EPT -- instead. ToDo: clean up, and remove this slightly bogus -- filter: - , mod /= gHC_PRIM + , mod /= moduleName gHC_PRIM -- Look it up in the HPT - , let mod_info = case lookupModuleEnv hpt mod of + , let mod_info = case lookupUFM hpt mod of Nothing -> pprPanic "hptRules" (ppr mod <+> ppr deps) Just x -> x @@ -294,6 +292,47 @@ hptRules hsc_env deps , rule <- md_rules (hm_details mod_info) ] \end{code} +%************************************************************************ +%* * +\subsection{The Finder cache} +%* * +%************************************************************************ + +\begin{code} +-- | The 'FinderCache' maps home module names to the result of +-- searching for that module. It records the results of searching for +-- modules along the search path. On @:load@, we flush the entire +-- contents of this cache. +-- +-- Although the @FinderCache@ range is 'FindResult' for convenience , +-- in fact it will only ever contain 'Found' or 'NotFound' entries. +-- +type FinderCache = ModuleNameEnv FindResult + +-- | The result of searching for an imported module. +data FindResult + = Found ModLocation Module + -- the module was found + | NoPackage PackageId + -- the requested package was not found + | FoundMultiple [PackageId] + -- *error*: both in multiple packages + | PackageHidden PackageId + -- for an explicit source import: the package containing the module is + -- not exposed. + | ModuleHidden PackageId + -- for an explicit source import: the package containing the module is + -- exposed, but the module itself is hidden. + | NotFound [FilePath] + -- the module was not found, the specified places were searched. + | NotFoundInPackage PackageId + -- the module was not found in this package + +-- | Cache that remembers where we found a particular module. Contains both +-- home modules and package modules. On @:load@, only home modules are +-- purged from this cache. +type ModLocationCache = ModuleEnv ModLocation +\end{code} %************************************************************************ %* * @@ -313,7 +352,6 @@ the declarations into a single indexed map in the @PersistentRenamerState@. \begin{code} data ModIface = ModIface { - mi_package :: !PackageIdH, -- Which package the module comes from mi_module :: !Module, mi_mod_vers :: !Version, -- Module version: changes when anything changes @@ -408,7 +446,6 @@ data ModGuts mg_boot :: IsBootInterface, -- Whether it's an hs-boot module mg_exports :: !NameSet, -- What it exports mg_deps :: !Dependencies, -- What is below it, directly or otherwise - mg_home_mods :: !HomeModules, -- For calling isHomeModule etc. mg_dir_imps :: ![Module], -- Directly-imported modules; used to -- generate initialisation code mg_usages :: ![Usage], -- Version info for what it needed @@ -458,7 +495,6 @@ data CgGuts -- initialisation code cg_foreign :: !ForeignStubs, - cg_home_mods :: !HomeModules, -- for calling isHomeModule etc. cg_dep_pkgs :: ![PackageId] -- Used to generate #includes for C code gen } @@ -489,10 +525,9 @@ data ForeignStubs = NoStubs \end{code} \begin{code} -emptyModIface :: PackageIdH -> Module -> ModIface -emptyModIface pkg mod - = ModIface { mi_package = pkg, - mi_module = mod, +emptyModIface :: Module -> ModIface +emptyModIface mod + = ModIface { mi_module = mod, mi_mod_vers = initialVersion, mi_orphan = False, mi_boot = False, @@ -546,25 +581,32 @@ emptyInteractiveContext ic_type_env = emptyTypeEnv } icPrintUnqual :: InteractiveContext -> PrintUnqualified -icPrintUnqual ictxt = unQualInScope (ic_rn_gbl_env ictxt) +icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt) \end{code} -@unQualInScope@ returns a function that takes a @Name@ and tells whether -its unqualified name is in scope. This is put as a boolean flag in -the @Name@'s provenance to guide whether or not to print the name qualified -in error messages. +%************************************************************************ +%* * + Building a PrintUnqualified +%* * +%************************************************************************ \begin{code} -unQualInScope :: GlobalRdrEnv -> PrintUnqualified --- True if 'f' is in scope, and has only one binding, --- and the thing it is bound to is the name we are looking for --- (i.e. false if A.f and B.f are both in scope as unqualified 'f') --- --- [Out of date] Also checks for built-in syntax, which is always 'in scope' -unQualInScope env mod occ - = case lookupGRE_RdrName (mkRdrUnqual occ) env of - [gre] -> nameModule (gre_name gre) == mod - other -> False +mkPrintUnqualified :: GlobalRdrEnv -> PrintUnqualified +mkPrintUnqualified env = (qual_name, qual_mod) + where + qual_name mod occ + | null gres = Just (moduleName mod) + -- it isn't in scope at all, this probably shouldn't happen, + -- but we'll qualify it by the original module anyway. + | any unQualOK gres = Nothing + | (Imported is : _) <- map gre_prov gres, (idecl : _) <- is + = Just (is_as (is_decl idecl)) + | otherwise = panic "mkPrintUnqualified" + where + gres = [ gre | gre <- lookupGlobalRdrEnv env occ, + nameModule (gre_name gre) == mod ] + + qual_mod mod = Nothing -- For now... \end{code} @@ -637,11 +679,21 @@ extendTypeEnvList env things = foldl extendTypeEnv env things \end{code} \begin{code} -lookupType :: HomePackageTable -> PackageTypeEnv -> Name -> Maybe TyThing -lookupType hpt pte name - = case lookupModuleEnv hpt (nameModule name) of - Just details -> lookupNameEnv (md_types (hm_details details)) name - Nothing -> lookupNameEnv pte name +lookupType :: DynFlags + -> HomePackageTable + -> PackageTypeEnv + -> Name + -> Maybe TyThing + +lookupType dflags hpt pte name + -- in one-shot, we don't use the HPT + | not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg + = do hm <- lookupUFM hpt (moduleName mod) -- Maybe monad + lookupNameEnv (md_types (hm_details hm)) name + | otherwise + = lookupNameEnv pte name + where mod = nameModule name + this_pkg = thisPackage dflags \end{code} @@ -809,7 +861,7 @@ type IsBootInterface = Bool -- Invariant: the dependencies of a module M never includes M -- Invariant: the lists are unordered, with no duplicates data Dependencies - = Deps { dep_mods :: [(Module,IsBootInterface)], -- Home-package module dependencies + = Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies dep_pkgs :: [PackageId], -- External package dependencies dep_orphs :: [Module] } -- Orphan modules (whether home or external pkg) deriving( Eq ) @@ -819,7 +871,7 @@ noDependencies :: Dependencies noDependencies = Deps [] [] [] data Usage - = Usage { usg_name :: Module, -- Name of the module + = Usage { usg_name :: ModuleName, -- Name of the module usg_mod :: Version, -- Module version usg_entities :: [(OccName,Version)], -- Sorted by occurrence name usg_exports :: Maybe Version, -- Export-list version, if we depend on it @@ -859,14 +911,16 @@ type PackageInstEnv = InstEnv data ExternalPackageState = EPS { - eps_is_boot :: !(ModuleEnv (Module, IsBootInterface)), - -- In OneShot mode (only), home-package modules accumulate in the - -- external package state, and are sucked in lazily. - -- For these home-pkg modules (only) we need to record which are - -- boot modules. We set this field after loading all the - -- explicitly-imported interfaces, but before doing anything else + eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)), + -- In OneShot mode (only), home-package modules + -- accumulate in the external package state, and are + -- sucked in lazily. For these home-pkg modules + -- (only) we need to record which are boot modules. + -- We set this field after loading all the + -- explicitly-imported interfaces, but before doing + -- anything else -- - -- The Module part is not necessary, but it's useful for + -- The ModuleName part is not necessary, but it's useful for -- debug prints, and it's convenient because this field comes -- direct from TcRnTypes.ImportAvails.imp_dep_mods @@ -957,13 +1011,13 @@ emptyMG = [] data ModSummary = ModSummary { - ms_mod :: Module, -- Name of the module + ms_mod :: Module, -- Identity of the module ms_hsc_src :: HscSource, -- Source is Haskell, hs-boot, external core ms_location :: ModLocation, -- Location ms_hs_date :: ClockTime, -- Timestamp of source file ms_obj_date :: Maybe ClockTime, -- Timestamp of object, maybe - ms_srcimps :: [Located Module], -- Source imports - ms_imps :: [Located Module], -- Non-source imports + ms_srcimps :: [Located ModuleName], -- Source imports + ms_imps :: [Located ModuleName], -- Non-source imports ms_hspp_file :: FilePath, -- Filename of preprocessed source. ms_hspp_opts :: DynFlags, -- Cached flags from OPTIONS, INCLUDE -- and LANGUAGE pragmas. @@ -1011,7 +1065,7 @@ showModMsg target recomp mod_summary char ')']) where mod = ms_mod mod_summary - mod_str = moduleString mod ++ hscSourceString (ms_hsc_src mod_summary) + mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) \end{code} diff --git a/compiler/main/PackageConfig.hs b/compiler/main/PackageConfig.hs index e19a10d..bfd2f34 100644 --- a/compiler/main/PackageConfig.hs +++ b/compiler/main/PackageConfig.hs @@ -6,14 +6,21 @@ module PackageConfig ( -- * PackageId PackageId, mkPackageId, stringToPackageId, packageIdString, packageConfigId, - packageIdFS, fsToPackageId, + packageIdFS, fsToPackageId, unpackPackageId, -- * The PackageConfig type: information about a package PackageConfig, InstalledPackageInfo(..), showPackageId, Version(..), PackageIdentifier(..), - defaultPackageConfig + defaultPackageConfig, + + -- * Wired-in PackageIds + basePackageId, + rtsPackageId, + haskell98PackageId, + thPackageId, + mainPackageId ) where #include "HsVersions.h" @@ -22,6 +29,7 @@ import Distribution.InstalledPackageInfo import Distribution.Package import Distribution.Version import FastString +import Text.ParserCombinators.ReadP ( readP_to_S ) -- ----------------------------------------------------------------------------- -- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we @@ -66,4 +74,40 @@ mkPackageId = stringToPackageId . showPackageId packageConfigId :: PackageConfig -> PackageId packageConfigId = mkPackageId . package +unpackPackageId :: PackageId -> Maybe PackageIdentifier +unpackPackageId p + = case [ pid | (pid,"") <- readP_to_S parsePackageId str ] of + [] -> Nothing + (pid:_) -> Just pid + where str = packageIdString p + +-- ----------------------------------------------------------------------------- +-- Package Ids that are wired in + +-- Certain packages are "known" to the compiler, in that we know about certain +-- entities that reside in these packages, and the compiler needs to +-- declare static Modules and Names that refer to these packages. Hence +-- the wired-in packages can't include version numbers, since we don't want +-- to bake the version numbers of these packages into GHC. +-- +-- So here's the plan. Wired-in packages are still versioned as +-- normal in the packages database, and you can still have multiple +-- versions of them installed. However, for each invocation of GHC, +-- only a single instance of each wired-in package will be recognised +-- (the desired one is selected via -package/-hide-package), and GHC +-- will use the unversioned PackageId below when referring to it, +-- including in .hi files and object file symbols. Unselected +-- versions of wired-in packages will be ignored, as will any other +-- package that depends directly or indirectly on it (much as if you +-- had used -ignore-package). + +basePackageId = fsToPackageId FSLIT("base") +rtsPackageId = fsToPackageId FSLIT("rts") +haskell98PackageId = fsToPackageId FSLIT("haskell98") +thPackageId = fsToPackageId FSLIT("template-haskell") + +-- This is the package Id for the program. It is the default package +-- Id if you don't specify a package name. We don't add this prefix +-- to symbol name, since there can be only one main package per program. +mainPackageId = fsToPackageId FSLIT("main") diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index ae6b188..2249411 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -12,16 +12,11 @@ module Packages ( extendPackageConfigMap, dumpPackages, -- * Reading the package config, and processing cmdline args - PackageIdH(..), isHomePackage, PackageState(..), - mkPackageState, initPackages, getPackageDetails, - checkForPackageConflicts, lookupModuleInAllPackages, - HomeModules, mkHomeModules, isHomeModule, - -- * Inspecting the set of packages in scope getPackageIncludePath, getPackageCIncludes, @@ -48,7 +43,6 @@ import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) import UniqFM import Module -import FiniteMap import UniqSet import Util import Maybes ( expectJust, MaybeErr(..) ) @@ -67,6 +61,7 @@ import Distribution.Package import Distribution.Version import System.Directory ( doesFileExist, doesDirectoryExist, getDirectoryContents ) +import Data.Maybe ( catMaybes ) import Control.Monad ( foldM ) import Data.List ( nub, partition, sortBy, isSuffixOf ) import FastString @@ -91,9 +86,6 @@ import ErrUtils ( debugTraceMsg, putMsg, Message ) -- Let depExposedPackages be the transitive closure from exposedPackages of -- their dependencies. -- --- * It is an error for any two packages in depExposedPackages to provide the --- same module. --- -- * When searching for a module from an explicit import declaration, -- only the exposed modules in exposedPackages are valid. -- @@ -109,16 +101,6 @@ import ErrUtils ( debugTraceMsg, putMsg, Message ) -- contain any Haskell modules, and therefore won't be discovered -- by the normal mechanism of dependency tracking. - --- One important thing that the package state provides is a way to --- tell, for a given module, whether it is part of the current package --- or not. We need to know this for two reasons: --- --- * generating cross-DLL calls is different from intra-DLL calls --- (see below). --- * we don't record version information in interface files for entities --- in a different package. --- -- Notes on DLLs -- ~~~~~~~~~~~~~ -- When compiling module A, which imports module B, we need to @@ -143,29 +125,13 @@ data PackageState = PackageState { -- The exposed flags are adjusted according to -package and -- -hide-package flags, and -ignore-package removes packages. - moduleToPkgConfAll :: ModuleEnv [(PackageConfig,Bool)], + moduleToPkgConfAll :: UniqFM [(PackageConfig,Bool)] -- ModuleEnv mapping -- Derived from pkgIdMap. -- Maps Module to (pkgconf,exposed), where pkgconf is the -- PackageConfig for the package containing the module, and -- exposed is True if the package exposes that module. - - -- The PackageIds of some known packages - basePackageId :: PackageIdH, - rtsPackageId :: PackageIdH, - haskell98PackageId :: PackageIdH, - thPackageId :: PackageIdH } -data PackageIdH - = HomePackage -- The "home" package is the package curently - -- being compiled - | ExtPackage PackageId -- An "external" package is any other package - - -isHomePackage :: PackageIdH -> Bool -isHomePackage HomePackage = True -isHomePackage (ExtPackage _) = False - -- A PackageConfigMap maps a PackageId to a PackageConfig type PackageConfigMap = UniqFM PackageConfig @@ -194,8 +160,7 @@ getPackageDetails dflags ps = expectJust "getPackageDetails" (lookupPackage (pkg initPackages :: DynFlags -> IO DynFlags initPackages dflags = do pkg_map <- readPackageConfigs dflags; - state <- mkPackageState dflags pkg_map - return dflags{ pkgState = state } + mkPackageState dflags pkg_map -- ----------------------------------------------------------------------------- -- Reading the package database(s) @@ -297,7 +262,7 @@ mungePackagePaths top_dir ps = map munge_pkg ps -- When all the command-line options are in, we can process our package -- settings and populate the package state. -mkPackageState :: DynFlags -> PackageConfigMap -> IO PackageState +mkPackageState :: DynFlags -> PackageConfigMap -> IO DynFlags mkPackageState dflags orig_pkg_db = do -- -- Modify the package database according to the command-line flags @@ -317,10 +282,9 @@ mkPackageState dflags orig_pkg_db = do case pick str pkgs of Nothing -> missingPackageErr str Just (p,ps) -> procflags (p':ps') expl' flags - where pkgid = packageConfigId p - p' = p {exposed=True} + where p' = p {exposed=True} ps' = hideAll (pkgName (package p)) ps - expl' = addOneToUniqSet expl pkgid + expl' = package p : expl procflags pkgs expl (HidePackage str : flags) = do case partition (matches str) pkgs of ([],_) -> missingPackageErr str @@ -355,7 +319,7 @@ mkPackageState dflags orig_pkg_db = do where maybe_hide p | pkgName (package p) == name = p {exposed=False} | otherwise = p -- - (pkgs1,explicit) <- procflags (eltsUFM orig_pkg_db) emptyUniqSet flags + (pkgs1,explicit) <- procflags (eltsUFM orig_pkg_db) [] flags -- -- hide all packages for which there is also a later version -- that is already exposed. This just makes it non-fatal to have two @@ -377,11 +341,74 @@ mkPackageState dflags orig_pkg_db = do let pkg = package p, pkgName pkg == myname, pkgVersion pkg > myversion ] - a_later_version_is_exposed - = not (null later_versions) pkgs2 <- mapM maybe_hide pkgs1 -- + -- Now we must find our wired-in packages, and rename them to + -- their canonical names (eg. base-1.0 ==> base). + -- + let + wired_in_pkgids = [ basePackageId, + rtsPackageId, + haskell98PackageId, + thPackageId ] + + wired_in_names = map packageIdString wired_in_pkgids + + -- find which package corresponds to each wired-in package + -- delete any other packages with the same name + -- update the package and any dependencies to point to the new + -- one. + findWiredInPackage :: [PackageConfig] -> String + -> IO (Maybe PackageIdentifier) + findWiredInPackage pkgs wired_pkg = + case [ p | p <- pkgs, pkgName (package p) == wired_pkg, + exposed p ] of + [] -> do + debugTraceMsg dflags 2 $ + ptext SLIT("wired-in package ") + <> text wired_pkg + <> ptext SLIT(" not found.") + return Nothing + [one] -> do + debugTraceMsg dflags 2 $ + ptext SLIT("wired-in package ") + <> text wired_pkg + <> ptext SLIT(" mapped to ") + <> text (showPackageId (package one)) + return (Just (package one)) + more -> do + throwDyn (CmdLineError (showSDoc $ + ptext SLIT("there are multiple exposed packages that match wired-in package ") <> text wired_pkg)) + + mb_wired_in_ids <- mapM (findWiredInPackage pkgs2) wired_in_names + let + wired_in_ids = catMaybes mb_wired_in_ids + + deleteHiddenWiredInPackages pkgs = filter ok pkgs + where ok p = pkgName (package p) `notElem` wired_in_names + || exposed p + + updateWiredInDependencies pkgs = map upd_pkg pkgs + where upd_pkg p = p{ package = upd_pid (package p), + depends = map upd_pid (depends p) } + + upd_pid pid = case filter (== pid) wired_in_ids of + [] -> pid + (x:_) -> x{ pkgVersion = Version [] [] } + + pkgs3 = deleteHiddenWiredInPackages pkgs2 + + pkgs4 = updateWiredInDependencies pkgs3 + + explicit1 = map upd_pid explicit + + -- we must return an updated thisPackage, just in case we + -- are actually compiling one of the wired-in packages + Just old_this_pkg = unpackPackageId (thisPackage dflags) + new_this_pkg = mkPackageId (upd_pid old_this_pkg) + + -- -- Eliminate any packages which have dangling dependencies (perhaps -- because the package was removed by -ignore-package). -- @@ -403,41 +430,23 @@ mkPackageState dflags orig_pkg_db = do where dangling pid = pid `notElem` all_pids all_pids = map package pkgs -- - pkgs <- elimDanglingDeps pkgs2 + pkgs <- elimDanglingDeps pkgs4 let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs -- -- Find the transitive closure of dependencies of exposed -- let exposed_pkgids = [ packageConfigId p | p <- pkgs, exposed p ] dep_exposed <- closeDeps pkg_db exposed_pkgids - -- - -- Look up some known PackageIds - -- let - lookupPackageByName :: FastString -> PackageIdH - lookupPackageByName nm = - case [ conf | p <- dep_exposed, - Just conf <- [lookupPackage pkg_db p], - nm == mkFastString (pkgName (package conf)) ] of - [] -> HomePackage - (p:ps) -> ExtPackage (mkPackageId (package p)) - - -- Get the PackageIds for some known packages (we know the names, - -- but we don't know the versions). Some of these packages might - -- not exist in the database, so they are Maybes. - basePackageId = lookupPackageByName basePackageName - rtsPackageId = lookupPackageByName rtsPackageName - haskell98PackageId = lookupPackageByName haskell98PackageName - thPackageId = lookupPackageByName thPackageName - -- add base & rts to the explicit packages - basicLinkedPackages = [basePackageId,rtsPackageId] - explicit' = addListToUniqSet explicit - [ p | ExtPackage p <- basicLinkedPackages ] + basicLinkedPackages = filter (flip elemUFM pkg_db) + [basePackageId,rtsPackageId] + explicit2 = addListToUniqSet (mkUniqSet (map mkPackageId explicit1)) + basicLinkedPackages -- -- Close the explicit packages with their dependencies -- - dep_explicit <- closeDeps pkg_db (uniqSetToList explicit') + dep_explicit <- closeDeps pkg_db (uniqSetToList explicit2) -- -- Build up a mapping from Module -> PackageConfig for all modules. -- Discover any conflicts at the same time, and factor in the new exposed @@ -445,107 +454,31 @@ mkPackageState dflags orig_pkg_db = do -- let mod_map = mkModuleMap pkg_db dep_exposed - return PackageState{ explicitPackages = dep_explicit, - origPkgIdMap = orig_pkg_db, - pkgIdMap = pkg_db, - moduleToPkgConfAll = mod_map, - basePackageId = basePackageId, - rtsPackageId = rtsPackageId, - haskell98PackageId = haskell98PackageId, - thPackageId = thPackageId - } + pstate = PackageState{ explicitPackages = dep_explicit, + origPkgIdMap = orig_pkg_db, + pkgIdMap = pkg_db, + moduleToPkgConfAll = mod_map + } + + return dflags{ pkgState = pstate, thisPackage = new_this_pkg } -- done! -basePackageName = FSLIT("base") -rtsPackageName = FSLIT("rts") -haskell98PackageName = FSLIT("haskell98") -thPackageName = FSLIT("template-haskell") - -- Template Haskell libraries in here mkModuleMap :: PackageConfigMap -> [PackageId] - -> ModuleEnv [(PackageConfig, Bool)] + -> UniqFM [(PackageConfig, Bool)] mkModuleMap pkg_db pkgs = foldr extend_modmap emptyUFM pkgs where - extend_modmap pkgname modmap = + extend_modmap pkgid modmap = addListToUFM_C (++) modmap [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods] where - pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgname) - exposed_mods = map mkModule (exposedModules pkg) - hidden_mods = map mkModule (hiddenModules pkg) - all_mods = exposed_mods ++ hidden_mods - --- ----------------------------------------------------------------------------- --- Check for conflicts in the program. - --- | A conflict arises if the program contains two modules with the same --- name, which can arise if the program depends on multiple packages that --- expose the same module, or if the program depends on a package that --- contains a module also present in the program (the "home package"). --- -checkForPackageConflicts - :: DynFlags - -> [Module] -- modules in the home package - -> [PackageId] -- packages on which the program depends - -> MaybeErr Message () - -checkForPackageConflicts dflags mods pkgs = do - let - state = pkgState dflags - pkg_db = pkgIdMap state - -- - dep_pkgs <- closeDepsErr pkg_db pkgs - - let - extend_modmap pkgname modmap = - addListToFM_C (++) modmap - [(m, [(pkg, m `elem` exposed_mods)]) | m <- all_mods] - where - pkg = expectJust "checkForPackageConflicts" - (lookupPackage pkg_db pkgname) - exposed_mods = map mkModule (exposedModules pkg) - hidden_mods = map mkModule (hiddenModules pkg) + pkg = expectJust "mkModuleMap" (lookupPackage pkg_db pkgid) + exposed_mods = map mkModuleName (exposedModules pkg) + hidden_mods = map mkModuleName (hiddenModules pkg) all_mods = exposed_mods ++ hidden_mods - mod_map = foldr extend_modmap emptyFM pkgs - mod_map_list :: [(Module,[(PackageConfig,Bool)])] - mod_map_list = fmToList mod_map - - overlaps = [ (m, map fst ps) | (m,ps@(_:_:_)) <- mod_map_list ] - -- - if not (null overlaps) - then Failed (pkgOverlapError overlaps) - else do - - let - overlap_mods = [ (mod,pkg) - | mod <- mods, - Just ((pkg,_):_) <- [lookupFM mod_map mod] ] - -- will be only one package here - if not (null overlap_mods) - then Failed (modOverlapError overlap_mods) - else do - - return () - -pkgOverlapError overlaps = vcat (map msg overlaps) - where - msg (mod,pkgs) = - text "conflict: module" <+> quotes (ppr mod) - <+> ptext SLIT("is present in multiple packages:") - <+> hsep (punctuate comma (map pprPkg pkgs)) - -modOverlapError overlaps = vcat (map msg overlaps) - where - msg (mod,pkg) = fsep [ - text "conflict: module", - quotes (ppr mod), - ptext SLIT("belongs to the current program/library"), - ptext SLIT("and also to package"), - pprPkg pkg ] - pprPkg :: PackageConfig -> SDoc pprPkg p = text (showPackageId (package p)) @@ -625,9 +558,9 @@ getPackageFrameworks dflags pkgs = do -- | Takes a Module, and if the module is in a package returns -- @(pkgconf,exposed)@ where pkgconf is the PackageConfig for that package, -- and exposed is True if the package exposes the module. -lookupModuleInAllPackages :: DynFlags -> Module -> [(PackageConfig,Bool)] +lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)] lookupModuleInAllPackages dflags m = - case lookupModuleEnv (moduleToPkgConfAll (pkgState dflags)) m of + case lookupUFM (moduleToPkgConfAll (pkgState dflags)) m of Nothing -> [] Just ps -> ps @@ -673,24 +606,11 @@ missingPackageErr p = throwDyn (CmdLineError (showSDoc (missingPackageMsg p))) missingPackageMsg p = ptext SLIT("unknown package:") <+> text p -- ----------------------------------------------------------------------------- --- The home module set - -newtype HomeModules = HomeModules ModuleSet - -mkHomeModules :: [Module] -> HomeModules -mkHomeModules = HomeModules . mkModuleSet - -isHomeModule :: HomeModules -> Module -> Bool -isHomeModule (HomeModules set) mod = elemModuleSet mod set - --- Determining whether a Name refers to something in another package or not. --- Cross-package references need to be handled differently when dynamically- --- linked libraries are involved. -isDllName :: HomeModules -> Name -> Bool -isDllName pdeps name +isDllName :: PackageId -> Name -> Bool +isDllName this_pkg name | opt_Static = False - | Just mod <- nameModule_maybe name = not (isHomeModule pdeps mod) + | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg | otherwise = False -- no, it is not even an external name -- ----------------------------------------------------------------------------- diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 370e532..c0d19df 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -8,8 +8,7 @@ module TidyPgm( mkBootModDetails, tidyProgram ) where #include "HsVersions.h" -import DynFlags ( DynFlag(..), dopt ) -import Packages ( HomeModules ) +import DynFlags ( DynFlag(..), DynFlags(..), dopt ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) @@ -50,6 +49,7 @@ import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), ) import Maybes ( orElse, mapCatMaybes ) import ErrUtils ( showPass, dumpIfSet_core ) +import PackageConfig ( PackageId ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) import Maybe ( isJust ) @@ -238,7 +238,6 @@ tidyProgram hsc_env mg_binds = binds, mg_rules = imp_rules, mg_dir_imps = dir_imps, mg_deps = deps, - mg_home_mods = home_mods, mg_foreign = foreign_stubs }) = do { let dflags = hsc_dflags hsc_env @@ -257,7 +256,7 @@ tidyProgram hsc_env -- (It's a sort of mutual recursion.) } - ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env home_mods mod type_env ext_ids binds + ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds ; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc @@ -285,7 +284,6 @@ tidyProgram hsc_env cg_binds = all_tidy_binds, cg_dir_imps = dir_imps, cg_foreign = foreign_stubs, - cg_home_mods = home_mods, cg_dep_pkgs = dep_pkgs deps }, ModDetails { md_types = tidy_type_env, @@ -535,7 +533,6 @@ findExternalRules binds non_local_rules ext_ids -- * subst_env: A Var->Var mapping that substitutes the new Var for the old tidyTopBinds :: HscEnv - -> HomeModules -> Module -> TypeEnv -> IdEnv Bool -- Domain = Ids that should be external @@ -543,7 +540,7 @@ tidyTopBinds :: HscEnv -> [CoreBind] -> IO (TidyEnv, [CoreBind]) -tidyTopBinds hsc_env hmods mod type_env ext_ids binds +tidyTopBinds hsc_env mod type_env ext_ids binds = tidy init_env binds where nc_var = hsc_NC hsc_env @@ -567,13 +564,15 @@ tidyTopBinds hsc_env hmods mod type_env ext_ids binds -- since their names are "taken". -- The type environment is a convenient source of such things. + this_pkg = thisPackage (hsc_dflags hsc_env) + tidy env [] = return (env, []) - tidy env (b:bs) = do { (env1, b') <- tidyTopBind hmods mod nc_var ext_ids env b + tidy env (b:bs) = do { (env1, b') <- tidyTopBind this_pkg mod nc_var ext_ids env b ; (env2, bs') <- tidy env1 bs ; return (env2, b':bs') } ------------------------ -tidyTopBind :: HomeModules +tidyTopBind :: PackageId -> Module -> IORef NameCache -- For allocating new unique names -> IdEnv Bool -- Domain = Ids that should be external @@ -581,16 +580,16 @@ tidyTopBind :: HomeModules -> TidyEnv -> CoreBind -> IO (TidyEnv, CoreBind) -tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) +tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs) ; subst2 = extendVarEnv subst1 bndr bndr' ; tidy_env2 = (occ_env2, subst2) } ; return (tidy_env2, NonRec bndr' rhs') } where - caf_info = hasCafRefs hmods subst1 (idArity bndr) rhs + caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs -tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) +tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info) names' prs @@ -603,7 +602,7 @@ tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info - | or [ mayHaveCafRefs (hasCafRefs hmods subst1 (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -779,13 +778,13 @@ it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: HomeModules -> VarEnv Var -> Arity -> CoreExpr -> CafInfo -hasCafRefs hmods p arity expr +hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo +hasCafRefs this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefs p expr) - is_caf = not (arity > 0 || rhsIsStatic hmods expr) + is_caf = not (arity > 0 || rhsIsStatic this_pkg expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity -- knows how much eta expansion is going to be done by diff --git a/compiler/ndpFlatten/FlattenMonad.hs b/compiler/ndpFlatten/FlattenMonad.hs index 4540508..a9cc53f 100644 --- a/compiler/ndpFlatten/FlattenMonad.hs +++ b/compiler/ndpFlatten/FlattenMonad.hs @@ -75,7 +75,7 @@ import VarEnv (VarEnv, emptyVarEnv, zipVarEnv, plusVarEnv, elemVarEnv, lookupVarEnv, lookupVarEnv_NF, delVarEnvList) import Type (Type, tyConAppTyCon) import HscTypes (HomePackageTable, - ExternalPackageState(eps_PTE), HscEnv(hsc_HPT), + ExternalPackageState(eps_PTE), HscEnv(..), TyThing(..), lookupType) import PrelNames ( fstName, andName, orName, lengthPName, replicatePName, mapPName, bpermutePName, @@ -83,6 +83,7 @@ import PrelNames ( fstName, andName, orName, import TysPrim ( charPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) import PrimOp ( PrimOp(..) ) import PrelInfo ( primOpId ) +import DynFlags (DynFlags) import CoreSyn (Expr(..), Bind(..), CoreBndr, CoreExpr, CoreBind, mkApps) import CoreUtils (exprType) import FastString (FastString) @@ -128,11 +129,12 @@ data FlattenState = FlattenState { -- initial value of the flattening state -- -initialFlattenState :: ExternalPackageState +initialFlattenState :: DynFlags + -> ExternalPackageState -> HomePackageTable -> UniqSupply -> FlattenState -initialFlattenState eps hpt us = +initialFlattenState dflags eps hpt us = FlattenState { us = us, env = lookup, @@ -142,7 +144,7 @@ initialFlattenState eps hpt us = } where lookup n = - case lookupType hpt (eps_PTE eps) n of + case lookupType dflags hpt (eps_PTE eps) n of Just (AnId v) -> v _ -> pprPanic "FlattenMonad: unknown name:" (ppr n) @@ -167,7 +169,8 @@ runFlatten :: HscEnv -> Flatten a -> a runFlatten hsc_env eps us m - = fst $ unFlatten m (initialFlattenState eps (hsc_HPT hsc_env) us) + = fst $ unFlatten m (initialFlattenState (hsc_dflags hsc_env) + eps (hsc_HPT hsc_env) us) -- variable generation diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index a750397..da16bff 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -394,7 +394,7 @@ optqualified :: { Bool } : 'qualified' { True } | {- empty -} { False } -maybeas :: { Located (Maybe Module) } +maybeas :: { Located (Maybe ModuleName) } : 'as' modid { LL (Just (unLoc $2)) } | {- empty -} { noLoc Nothing } @@ -1545,10 +1545,10 @@ close :: { () } ----------------------------------------------------------------------------- -- Miscellaneous (mostly renamings) -modid :: { Located Module } - : CONID { L1 $ mkModuleFS (getCONID $1) } +modid :: { Located ModuleName } + : CONID { L1 $ mkModuleNameFS (getCONID $1) } | QCONID { L1 $ let (mod,c) = getQCONID $1 in - mkModuleFS + mkModuleNameFS (mkFastString (unpackFS mod ++ '.':unpackFS c)) } diff --git a/compiler/parser/ParserCore.y b/compiler/parser/ParserCore.y index 02a6c7b..a9669b2 100644 --- a/compiler/parser/ParserCore.y +++ b/compiler/parser/ParserCore.y @@ -10,6 +10,7 @@ import OccName import Kind( Kind(..) ) import Name( nameOccName, nameModule ) import Module +import PackageConfig ( mainPackageId ) import ParserCoreUtils import LexCore import Literal @@ -72,7 +73,8 @@ module :: { HsExtCore RdrName } : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 } modid :: { Module } - : CNAME { mkModuleFS (mkFastString $1) } + : CNAME { mkModule mainPackageId -- ToDo: wrong + (mkModuleNameFS (mkFastString $1)) } ------------------------------------------------------------- -- Type and newtype declarations are in HsSyn syntax diff --git a/compiler/prelude/PrelNames.lhs b/compiler/prelude/PrelNames.lhs index ae544b3..5d61075 100644 --- a/compiler/prelude/PrelNames.lhs +++ b/compiler/prelude/PrelNames.lhs @@ -49,7 +49,8 @@ module PrelNames ( #include "HsVersions.h" -import Module ( Module, mkModule ) +import PackageConfig +import Module ( Module, ModuleName, mkModule, mkModuleNameFS ) import OccName ( dataName, tcName, clsName, varName, mkOccNameFS, mkVarOccFS ) import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual ) @@ -222,55 +223,68 @@ genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] --MetaHaskell Extension Add a new module here \begin{code} -pRELUDE = mkModule "Prelude" -gHC_PRIM = mkModule "GHC.Prim" -- Primitive types and values -pREL_BASE = mkModule "GHC.Base" -pREL_ENUM = mkModule "GHC.Enum" -pREL_SHOW = mkModule "GHC.Show" -pREL_READ = mkModule "GHC.Read" -pREL_NUM = mkModule "GHC.Num" -pREL_LIST = mkModule "GHC.List" -pREL_PARR = mkModule "GHC.PArr" -pREL_TUP = mkModule "Data.Tuple" -pREL_EITHER = mkModule "Data.Either" -pREL_PACK = mkModule "GHC.Pack" -pREL_CONC = mkModule "GHC.Conc" -pREL_IO_BASE = mkModule "GHC.IOBase" -pREL_ST = mkModule "GHC.ST" -pREL_ARR = mkModule "GHC.Arr" -pREL_STABLE = mkModule "GHC.Stable" -pREL_ADDR = mkModule "GHC.Addr" -pREL_PTR = mkModule "GHC.Ptr" -pREL_ERR = mkModule "GHC.Err" -pREL_REAL = mkModule "GHC.Real" -pREL_FLOAT = mkModule "GHC.Float" -pREL_TOP_HANDLER= mkModule "GHC.TopHandler" -sYSTEM_IO = mkModule "System.IO" -dYNAMIC = mkModule "Data.Dynamic" -tYPEABLE = mkModule "Data.Typeable" -gENERICS = mkModule "Data.Generics.Basics" -dOTNET = mkModule "GHC.Dotnet" - -rEAD_PREC = mkModule "Text.ParserCombinators.ReadPrec" -lEX = mkModule "Text.Read.Lex" - -mAIN = mkModule "Main" -pREL_INT = mkModule "GHC.Int" -pREL_WORD = mkModule "GHC.Word" -mONAD = mkModule "Control.Monad" -mONAD_FIX = mkModule "Control.Monad.Fix" -aRROW = mkModule "Control.Arrow" -rANDOM = mkModule "System.Random" - -gLA_EXTS = mkModule "GHC.Exts" -rOOT_MAIN = mkModule ":Main" -- Root module for initialisation +pRELUDE = mkBaseModule_ pRELUDE_NAME +gHC_PRIM = mkBaseModule FSLIT("GHC.Prim") -- Primitive types and values +gHC_BASE = mkBaseModule FSLIT("GHC.Base") +gHC_ENUM = mkBaseModule FSLIT("GHC.Enum") +gHC_SHOW = mkBaseModule FSLIT("GHC.Show") +gHC_READ = mkBaseModule FSLIT("GHC.Read") +gHC_NUM = mkBaseModule FSLIT("GHC.Num") +gHC_LIST = mkBaseModule FSLIT("GHC.List") +gHC_PARR = mkBaseModule FSLIT("GHC.PArr") +dATA_TUP = mkBaseModule FSLIT("Data.Tuple") +dATA_EITHER = mkBaseModule FSLIT("Data.Either") +gHC_PACK = mkBaseModule FSLIT("GHC.Pack") +gHC_CONC = mkBaseModule FSLIT("GHC.Conc") +gHC_IO_BASE = mkBaseModule FSLIT("GHC.IOBase") +gHC_ST = mkBaseModule FSLIT("GHC.ST") +gHC_ARR = mkBaseModule FSLIT("GHC.Arr") +gHC_STABLE = mkBaseModule FSLIT("GHC.Stable") +gHC_ADDR = mkBaseModule FSLIT("GHC.Addr") +gHC_PTR = mkBaseModule FSLIT("GHC.Ptr") +gHC_ERR = mkBaseModule FSLIT("GHC.Err") +gHC_REAL = mkBaseModule FSLIT("GHC.Real") +gHC_FLOAT = mkBaseModule FSLIT("GHC.Float") +gHC_TOP_HANDLER = mkBaseModule FSLIT("GHC.TopHandler") +sYSTEM_IO = mkBaseModule FSLIT("System.IO") +dYNAMIC = mkBaseModule FSLIT("Data.Dynamic") +tYPEABLE = mkBaseModule FSLIT("Data.Typeable") +gENERICS = mkBaseModule FSLIT("Data.Generics.Basics") +dOTNET = mkBaseModule FSLIT("GHC.Dotnet") +rEAD_PREC = mkBaseModule FSLIT("Text.ParserCombinators.ReadPrec") +lEX = mkBaseModule FSLIT("Text.Read.Lex") +gHC_INT = mkBaseModule FSLIT("GHC.Int") +gHC_WORD = mkBaseModule FSLIT("GHC.Word") +mONAD = mkBaseModule FSLIT("Control.Monad") +mONAD_FIX = mkBaseModule FSLIT("Control.Monad.Fix") +aRROW = mkBaseModule FSLIT("Control.Arrow") +rANDOM = mkBaseModule FSLIT("System.Random") +gLA_EXTS = mkBaseModule FSLIT("GHC.Exts") + +mAIN = mkMainModule_ mAIN_NAME +rOOT_MAIN = mkMainModule FSLIT(":Main") -- Root module for initialisation + -- The ':xxx' makes a module name that the user can never -- use himself. The z-encoding for ':' is "ZC", so the z-encoded -- module name still starts with a capital letter, which keeps -- the z-encoded version consistent. +iNTERACTIVE = mkMainModule FSLIT(":Interactive") +thFAKE = mkMainModule FSLIT(":THFake") + +pRELUDE_NAME = mkModuleNameFS FSLIT("Prelude") +mAIN_NAME = mkModuleNameFS FSLIT("Main") + +mkBaseModule :: FastString -> Module +mkBaseModule m = mkModule basePackageId (mkModuleNameFS m) + +mkBaseModule_ :: ModuleName -> Module +mkBaseModule_ m = mkModule basePackageId m + +mkMainModule :: FastString -> Module +mkMainModule m = mkModule mainPackageId (mkModuleNameFS m) -iNTERACTIVE = mkModule ":Interactive" -thFAKE = mkModule ":THFake" +mkMainModule_ :: ModuleName -> Module +mkMainModule_ m = mkModule mainPackageId m \end{code} %************************************************************************ @@ -281,8 +295,8 @@ thFAKE = mkModule ":THFake" \begin{code} mkTupleModule :: Boxity -> Arity -> Module -mkTupleModule Boxed 0 = pREL_BASE -mkTupleModule Boxed _ = pREL_TUP +mkTupleModule Boxed 0 = gHC_BASE +mkTupleModule Boxed _ = dATA_TUP mkTupleModule Unboxed _ = gHC_PRIM \end{code} @@ -300,13 +314,13 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main") eq_RDR = nameRdrName eqName ge_RDR = nameRdrName geName -ne_RDR = varQual_RDR pREL_BASE FSLIT("/=") -le_RDR = varQual_RDR pREL_BASE FSLIT("<=") -gt_RDR = varQual_RDR pREL_BASE FSLIT(">") -compare_RDR = varQual_RDR pREL_BASE FSLIT("compare") -ltTag_RDR = dataQual_RDR pREL_BASE FSLIT("LT") -eqTag_RDR = dataQual_RDR pREL_BASE FSLIT("EQ") -gtTag_RDR = dataQual_RDR pREL_BASE FSLIT("GT") +ne_RDR = varQual_RDR gHC_BASE FSLIT("/=") +le_RDR = varQual_RDR gHC_BASE FSLIT("<=") +gt_RDR = varQual_RDR gHC_BASE FSLIT(">") +compare_RDR = varQual_RDR gHC_BASE FSLIT("compare") +ltTag_RDR = dataQual_RDR gHC_BASE FSLIT("LT") +eqTag_RDR = dataQual_RDR gHC_BASE FSLIT("EQ") +gtTag_RDR = dataQual_RDR gHC_BASE FSLIT("GT") eqClass_RDR = nameRdrName eqClassName numClass_RDR = nameRdrName numClassName @@ -314,8 +328,8 @@ ordClass_RDR = nameRdrName ordClassName enumClass_RDR = nameRdrName enumClassName monadClass_RDR = nameRdrName monadClassName -map_RDR = varQual_RDR pREL_BASE FSLIT("map") -append_RDR = varQual_RDR pREL_BASE FSLIT("++") +map_RDR = varQual_RDR gHC_BASE FSLIT("map") +append_RDR = varQual_RDR gHC_BASE FSLIT("++") foldr_RDR = nameRdrName foldrName build_RDR = nameRdrName buildName @@ -328,8 +342,8 @@ and_RDR = nameRdrName andName left_RDR = nameRdrName leftDataConName right_RDR = nameRdrName rightDataConName -fromEnum_RDR = varQual_RDR pREL_ENUM FSLIT("fromEnum") -toEnum_RDR = varQual_RDR pREL_ENUM FSLIT("toEnum") +fromEnum_RDR = varQual_RDR gHC_ENUM FSLIT("fromEnum") +toEnum_RDR = varQual_RDR gHC_ENUM FSLIT("toEnum") enumFrom_RDR = nameRdrName enumFromName enumFromTo_RDR = nameRdrName enumFromToName @@ -348,7 +362,7 @@ unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name newStablePtr_RDR = nameRdrName newStablePtrName -wordDataCon_RDR = dataQual_RDR pREL_WORD FSLIT("W#") +wordDataCon_RDR = dataQual_RDR gHC_WORD FSLIT("W#") bindIO_RDR = nameRdrName bindIOName returnIO_RDR = nameRdrName returnIOName @@ -356,31 +370,31 @@ returnIO_RDR = nameRdrName returnIOName fromInteger_RDR = nameRdrName fromIntegerName fromRational_RDR = nameRdrName fromRationalName minus_RDR = nameRdrName minusName -times_RDR = varQual_RDR pREL_NUM FSLIT("*") -plus_RDR = varQual_RDR pREL_NUM FSLIT("+") - -compose_RDR = varQual_RDR pREL_BASE FSLIT(".") - -not_RDR = varQual_RDR pREL_BASE FSLIT("not") -getTag_RDR = varQual_RDR pREL_BASE FSLIT("getTag") -succ_RDR = varQual_RDR pREL_ENUM FSLIT("succ") -pred_RDR = varQual_RDR pREL_ENUM FSLIT("pred") -minBound_RDR = varQual_RDR pREL_ENUM FSLIT("minBound") -maxBound_RDR = varQual_RDR pREL_ENUM FSLIT("maxBound") -range_RDR = varQual_RDR pREL_ARR FSLIT("range") -inRange_RDR = varQual_RDR pREL_ARR FSLIT("inRange") -index_RDR = varQual_RDR pREL_ARR FSLIT("index") -unsafeIndex_RDR = varQual_RDR pREL_ARR FSLIT("unsafeIndex") -unsafeRangeSize_RDR = varQual_RDR pREL_ARR FSLIT("unsafeRangeSize") - -readList_RDR = varQual_RDR pREL_READ FSLIT("readList") -readListDefault_RDR = varQual_RDR pREL_READ FSLIT("readListDefault") -readListPrec_RDR = varQual_RDR pREL_READ FSLIT("readListPrec") -readListPrecDefault_RDR = varQual_RDR pREL_READ FSLIT("readListPrecDefault") -readPrec_RDR = varQual_RDR pREL_READ FSLIT("readPrec") -parens_RDR = varQual_RDR pREL_READ FSLIT("parens") -choose_RDR = varQual_RDR pREL_READ FSLIT("choose") -lexP_RDR = varQual_RDR pREL_READ FSLIT("lexP") +times_RDR = varQual_RDR gHC_NUM FSLIT("*") +plus_RDR = varQual_RDR gHC_NUM FSLIT("+") + +compose_RDR = varQual_RDR gHC_BASE FSLIT(".") + +not_RDR = varQual_RDR gHC_BASE FSLIT("not") +getTag_RDR = varQual_RDR gHC_BASE FSLIT("getTag") +succ_RDR = varQual_RDR gHC_ENUM FSLIT("succ") +pred_RDR = varQual_RDR gHC_ENUM FSLIT("pred") +minBound_RDR = varQual_RDR gHC_ENUM FSLIT("minBound") +maxBound_RDR = varQual_RDR gHC_ENUM FSLIT("maxBound") +range_RDR = varQual_RDR gHC_ARR FSLIT("range") +inRange_RDR = varQual_RDR gHC_ARR FSLIT("inRange") +index_RDR = varQual_RDR gHC_ARR FSLIT("index") +unsafeIndex_RDR = varQual_RDR gHC_ARR FSLIT("unsafeIndex") +unsafeRangeSize_RDR = varQual_RDR gHC_ARR FSLIT("unsafeRangeSize") + +readList_RDR = varQual_RDR gHC_READ FSLIT("readList") +readListDefault_RDR = varQual_RDR gHC_READ FSLIT("readListDefault") +readListPrec_RDR = varQual_RDR gHC_READ FSLIT("readListPrec") +readListPrecDefault_RDR = varQual_RDR gHC_READ FSLIT("readListPrecDefault") +readPrec_RDR = varQual_RDR gHC_READ FSLIT("readPrec") +parens_RDR = varQual_RDR gHC_READ FSLIT("parens") +choose_RDR = varQual_RDR gHC_READ FSLIT("choose") +lexP_RDR = varQual_RDR gHC_READ FSLIT("lexP") punc_RDR = dataQual_RDR lEX FSLIT("Punc") ident_RDR = dataQual_RDR lEX FSLIT("Ident") @@ -391,23 +405,23 @@ alt_RDR = varQual_RDR rEAD_PREC FSLIT("+++") reset_RDR = varQual_RDR rEAD_PREC FSLIT("reset") prec_RDR = varQual_RDR rEAD_PREC FSLIT("prec") -showList_RDR = varQual_RDR pREL_SHOW FSLIT("showList") -showList___RDR = varQual_RDR pREL_SHOW FSLIT("showList__") -showsPrec_RDR = varQual_RDR pREL_SHOW FSLIT("showsPrec") -showString_RDR = varQual_RDR pREL_SHOW FSLIT("showString") -showSpace_RDR = varQual_RDR pREL_SHOW FSLIT("showSpace") -showParen_RDR = varQual_RDR pREL_SHOW FSLIT("showParen") +showList_RDR = varQual_RDR gHC_SHOW FSLIT("showList") +showList___RDR = varQual_RDR gHC_SHOW FSLIT("showList__") +showsPrec_RDR = varQual_RDR gHC_SHOW FSLIT("showsPrec") +showString_RDR = varQual_RDR gHC_SHOW FSLIT("showString") +showSpace_RDR = varQual_RDR gHC_SHOW FSLIT("showSpace") +showParen_RDR = varQual_RDR gHC_SHOW FSLIT("showParen") typeOf_RDR = varQual_RDR tYPEABLE FSLIT("typeOf") mkTypeRep_RDR = varQual_RDR tYPEABLE FSLIT("mkTyConApp") mkTyConRep_RDR = varQual_RDR tYPEABLE FSLIT("mkTyCon") -undefined_RDR = varQual_RDR pREL_ERR FSLIT("undefined") +undefined_RDR = varQual_RDR gHC_ERR FSLIT("undefined") -crossDataCon_RDR = dataQual_RDR pREL_BASE FSLIT(":*:") -inlDataCon_RDR = dataQual_RDR pREL_BASE FSLIT("Inl") -inrDataCon_RDR = dataQual_RDR pREL_BASE FSLIT("Inr") -genUnitDataCon_RDR = dataQual_RDR pREL_BASE FSLIT("Unit") +crossDataCon_RDR = dataQual_RDR gHC_BASE FSLIT(":*:") +inlDataCon_RDR = dataQual_RDR gHC_BASE FSLIT("Inl") +inrDataCon_RDR = dataQual_RDR gHC_BASE FSLIT("Inr") +genUnitDataCon_RDR = dataQual_RDR gHC_BASE FSLIT("Unit") ---------------------- varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str) @@ -431,54 +445,54 @@ and it's convenient to write them all down in one place. \begin{code} -runMainIOName = varQual pREL_TOP_HANDLER FSLIT("runMainIO") runMainKey +runMainIOName = varQual gHC_TOP_HANDLER FSLIT("runMainIO") runMainKey -orderingTyConName = tcQual pREL_BASE FSLIT("Ordering") orderingTyConKey +orderingTyConName = tcQual gHC_BASE FSLIT("Ordering") orderingTyConKey -eitherTyConName = tcQual pREL_EITHER FSLIT("Either") eitherTyConKey +eitherTyConName = tcQual dATA_EITHER FSLIT("Either") eitherTyConKey leftDataConName = conName eitherTyConName FSLIT("Left") leftDataConKey rightDataConName = conName eitherTyConName FSLIT("Right") rightDataConKey -- Generics -crossTyConName = tcQual pREL_BASE FSLIT(":*:") crossTyConKey -plusTyConName = tcQual pREL_BASE FSLIT(":+:") plusTyConKey -genUnitTyConName = tcQual pREL_BASE FSLIT("Unit") genUnitTyConKey +crossTyConName = tcQual gHC_BASE FSLIT(":*:") crossTyConKey +plusTyConName = tcQual gHC_BASE FSLIT(":+:") plusTyConKey +genUnitTyConName = tcQual gHC_BASE FSLIT("Unit") genUnitTyConKey -- Base strings Strings -unpackCStringName = varQual pREL_BASE FSLIT("unpackCString#") unpackCStringIdKey -unpackCStringAppendName = varQual pREL_BASE FSLIT("unpackAppendCString#") unpackCStringAppendIdKey -unpackCStringFoldrName = varQual pREL_BASE FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey -unpackCStringUtf8Name = varQual pREL_BASE FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey -eqStringName = varQual pREL_BASE FSLIT("eqString") eqStringIdKey +unpackCStringName = varQual gHC_BASE FSLIT("unpackCString#") unpackCStringIdKey +unpackCStringAppendName = varQual gHC_BASE FSLIT("unpackAppendCString#") unpackCStringAppendIdKey +unpackCStringFoldrName = varQual gHC_BASE FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey +unpackCStringUtf8Name = varQual gHC_BASE FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey +eqStringName = varQual gHC_BASE FSLIT("eqString") eqStringIdKey -- The 'inline' function -inlineIdName = varQual pREL_BASE FSLIT("inline") inlineIdKey +inlineIdName = varQual gHC_BASE FSLIT("inline") inlineIdKey -- Base classes (Eq, Ord, Functor) -eqClassName = clsQual pREL_BASE FSLIT("Eq") eqClassKey +eqClassName = clsQual gHC_BASE FSLIT("Eq") eqClassKey eqName = methName eqClassName FSLIT("==") eqClassOpKey -ordClassName = clsQual pREL_BASE FSLIT("Ord") ordClassKey +ordClassName = clsQual gHC_BASE FSLIT("Ord") ordClassKey geName = methName ordClassName FSLIT(">=") geClassOpKey -functorClassName = clsQual pREL_BASE FSLIT("Functor") functorClassKey +functorClassName = clsQual gHC_BASE FSLIT("Functor") functorClassKey -- Class Monad -monadClassName = clsQual pREL_BASE FSLIT("Monad") monadClassKey +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 -- Random PrelBase functions -otherwiseIdName = varQual pREL_BASE FSLIT("otherwise") otherwiseIdKey -foldrName = varQual pREL_BASE FSLIT("foldr") foldrIdKey -buildName = varQual pREL_BASE FSLIT("build") buildIdKey -augmentName = varQual pREL_BASE FSLIT("augment") augmentIdKey -appendName = varQual pREL_BASE FSLIT("++") appendIdKey -andName = varQual pREL_BASE FSLIT("&&") andIdKey -orName = varQual pREL_BASE FSLIT("||") orIdKey -assertName = varQual pREL_BASE FSLIT("assert") assertIdKey -breakpointName = varQual pREL_BASE FSLIT("breakpoint") breakpointIdKey -breakpointCondName= varQual pREL_BASE FSLIT("breakpointCond") breakpointCondIdKey +otherwiseIdName = varQual gHC_BASE FSLIT("otherwise") otherwiseIdKey +foldrName = varQual gHC_BASE FSLIT("foldr") foldrIdKey +buildName = varQual gHC_BASE FSLIT("build") buildIdKey +augmentName = varQual gHC_BASE FSLIT("augment") augmentIdKey +appendName = varQual gHC_BASE FSLIT("++") appendIdKey +andName = varQual gHC_BASE FSLIT("&&") andIdKey +orName = varQual gHC_BASE FSLIT("||") orIdKey +assertName = varQual gHC_BASE FSLIT("assert") assertIdKey +breakpointName = varQual gHC_BASE FSLIT("breakpoint") breakpointIdKey +breakpointCondName= varQual gHC_BASE FSLIT("breakpointCond") breakpointCondIdKey breakpointJumpName = mkInternalName breakpointJumpIdKey @@ -491,36 +505,36 @@ breakpointCondJumpName noSrcLoc -- PrelTup -fstName = varQual pREL_TUP FSLIT("fst") fstIdKey -sndName = varQual pREL_TUP FSLIT("snd") sndIdKey +fstName = varQual dATA_TUP FSLIT("fst") fstIdKey +sndName = varQual dATA_TUP FSLIT("snd") sndIdKey -- Module PrelNum -numClassName = clsQual pREL_NUM FSLIT("Num") numClassKey +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 pREL_NUM FSLIT("plusInteger") plusIntegerIdKey -timesIntegerName = varQual pREL_NUM FSLIT("timesInteger") timesIntegerIdKey -integerTyConName = tcQual pREL_NUM FSLIT("Integer") integerTyConKey +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 -- PrelReal types and classes -rationalTyConName = tcQual pREL_REAL FSLIT("Rational") rationalTyConKey -ratioTyConName = tcQual pREL_REAL FSLIT("Ratio") ratioTyConKey +rationalTyConName = tcQual gHC_REAL FSLIT("Rational") rationalTyConKey +ratioTyConName = tcQual gHC_REAL FSLIT("Ratio") ratioTyConKey ratioDataConName = conName ratioTyConName FSLIT(":%") ratioDataConKey -realClassName = clsQual pREL_REAL FSLIT("Real") realClassKey -integralClassName = clsQual pREL_REAL FSLIT("Integral") integralClassKey -realFracClassName = clsQual pREL_REAL FSLIT("RealFrac") realFracClassKey -fractionalClassName = clsQual pREL_REAL FSLIT("Fractional") fractionalClassKey +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 -- PrelFloat classes -floatingClassName = clsQual pREL_FLOAT FSLIT("Floating") floatingClassKey -realFloatClassName = clsQual pREL_FLOAT FSLIT("RealFloat") realFloatClassKey +floatingClassName = clsQual gHC_FLOAT FSLIT("Floating") floatingClassKey +realFloatClassName = clsQual gHC_FLOAT FSLIT("RealFloat") realFloatClassKey -- Class Ix -ixClassName = clsQual pREL_ARR FSLIT("Ix") ixClassKey +ixClassName = clsQual gHC_ARR FSLIT("Ix") ixClassKey -- Class Typeable typeableClassName = clsQual tYPEABLE FSLIT("Typeable") typeableClassKey @@ -540,78 +554,78 @@ typeableClassNames = [ typeableClassName, typeable1ClassName, typeable2ClassNam dataClassName = clsQual gENERICS FSLIT("Data") dataClassKey -- Error module -assertErrorName = varQual pREL_ERR FSLIT("assertError") assertErrorIdKey +assertErrorName = varQual gHC_ERR FSLIT("assertError") assertErrorIdKey -- Enum module (Enum, Bounded) -enumClassName = clsQual pREL_ENUM FSLIT("Enum") enumClassKey +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 -boundedClassName = clsQual pREL_ENUM FSLIT("Bounded") boundedClassKey +boundedClassName = clsQual gHC_ENUM FSLIT("Bounded") boundedClassKey -- List functions -concatName = varQual pREL_LIST FSLIT("concat") concatIdKey -filterName = varQual pREL_LIST FSLIT("filter") filterIdKey -zipName = varQual pREL_LIST FSLIT("zip") zipIdKey +concatName = varQual gHC_LIST FSLIT("concat") concatIdKey +filterName = varQual gHC_LIST FSLIT("filter") filterIdKey +zipName = varQual gHC_LIST FSLIT("zip") zipIdKey -- Class Show -showClassName = clsQual pREL_SHOW FSLIT("Show") showClassKey +showClassName = clsQual gHC_SHOW FSLIT("Show") showClassKey -- Class Read -readClassName = clsQual pREL_READ FSLIT("Read") readClassKey +readClassName = clsQual gHC_READ FSLIT("Read") readClassKey -- parallel array types and functions -enumFromToPName = varQual pREL_PARR FSLIT("enumFromToP") enumFromToPIdKey -enumFromThenToPName= varQual pREL_PARR FSLIT("enumFromThenToP") enumFromThenToPIdKey -nullPName = varQual pREL_PARR FSLIT("nullP") nullPIdKey -lengthPName = varQual pREL_PARR FSLIT("lengthP") lengthPIdKey -replicatePName = varQual pREL_PARR FSLIT("replicateP") replicatePIdKey -mapPName = varQual pREL_PARR FSLIT("mapP") mapPIdKey -filterPName = varQual pREL_PARR FSLIT("filterP") filterPIdKey -zipPName = varQual pREL_PARR FSLIT("zipP") zipPIdKey -crossPName = varQual pREL_PARR FSLIT("crossP") crossPIdKey -indexPName = varQual pREL_PARR FSLIT("!:") indexPIdKey -toPName = varQual pREL_PARR FSLIT("toP") toPIdKey -bpermutePName = varQual pREL_PARR FSLIT("bpermuteP") bpermutePIdKey -bpermuteDftPName = varQual pREL_PARR FSLIT("bpermuteDftP") bpermuteDftPIdKey -indexOfPName = varQual pREL_PARR FSLIT("indexOfP") indexOfPIdKey +enumFromToPName = varQual gHC_PARR FSLIT("enumFromToP") enumFromToPIdKey +enumFromThenToPName= varQual gHC_PARR FSLIT("enumFromThenToP") enumFromThenToPIdKey +nullPName = varQual gHC_PARR FSLIT("nullP") nullPIdKey +lengthPName = varQual gHC_PARR FSLIT("lengthP") lengthPIdKey +replicatePName = varQual gHC_PARR FSLIT("replicateP") replicatePIdKey +mapPName = varQual gHC_PARR FSLIT("mapP") mapPIdKey +filterPName = varQual gHC_PARR FSLIT("filterP") filterPIdKey +zipPName = varQual gHC_PARR FSLIT("zipP") zipPIdKey +crossPName = varQual gHC_PARR FSLIT("crossP") crossPIdKey +indexPName = varQual gHC_PARR FSLIT("!:") indexPIdKey +toPName = varQual gHC_PARR FSLIT("toP") toPIdKey +bpermutePName = varQual gHC_PARR FSLIT("bpermuteP") bpermutePIdKey +bpermuteDftPName = varQual gHC_PARR FSLIT("bpermuteDftP") bpermuteDftPIdKey +indexOfPName = varQual gHC_PARR FSLIT("indexOfP") indexOfPIdKey -- IOBase things -ioTyConName = tcQual pREL_IO_BASE FSLIT("IO") ioTyConKey +ioTyConName = tcQual gHC_IO_BASE FSLIT("IO") ioTyConKey ioDataConName = conName ioTyConName FSLIT("IO") ioDataConKey -thenIOName = varQual pREL_IO_BASE FSLIT("thenIO") thenIOIdKey -bindIOName = varQual pREL_IO_BASE FSLIT("bindIO") bindIOIdKey -returnIOName = varQual pREL_IO_BASE FSLIT("returnIO") returnIOIdKey -failIOName = varQual pREL_IO_BASE FSLIT("failIO") failIOIdKey +thenIOName = varQual gHC_IO_BASE FSLIT("thenIO") thenIOIdKey +bindIOName = varQual gHC_IO_BASE FSLIT("bindIO") bindIOIdKey +returnIOName = varQual gHC_IO_BASE FSLIT("returnIO") returnIOIdKey +failIOName = varQual gHC_IO_BASE FSLIT("failIO") failIOIdKey -- IO things printName = varQual sYSTEM_IO FSLIT("print") printIdKey -- Int, Word, and Addr things -int8TyConName = tcQual pREL_INT FSLIT("Int8") int8TyConKey -int16TyConName = tcQual pREL_INT FSLIT("Int16") int16TyConKey -int32TyConName = tcQual pREL_INT FSLIT("Int32") int32TyConKey -int64TyConName = tcQual pREL_INT FSLIT("Int64") int64TyConKey +int8TyConName = tcQual gHC_INT FSLIT("Int8") int8TyConKey +int16TyConName = tcQual gHC_INT FSLIT("Int16") int16TyConKey +int32TyConName = tcQual gHC_INT FSLIT("Int32") int32TyConKey +int64TyConName = tcQual gHC_INT FSLIT("Int64") int64TyConKey -- Word module -word8TyConName = tcQual pREL_WORD FSLIT("Word8") word8TyConKey -word16TyConName = tcQual pREL_WORD FSLIT("Word16") word16TyConKey -word32TyConName = tcQual pREL_WORD FSLIT("Word32") word32TyConKey -word64TyConName = tcQual pREL_WORD FSLIT("Word64") word64TyConKey -wordTyConName = tcQual pREL_WORD FSLIT("Word") wordTyConKey +word8TyConName = tcQual gHC_WORD FSLIT("Word8") word8TyConKey +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 -- PrelPtr module -ptrTyConName = tcQual pREL_PTR FSLIT("Ptr") ptrTyConKey -funPtrTyConName = tcQual pREL_PTR FSLIT("FunPtr") funPtrTyConKey +ptrTyConName = tcQual gHC_PTR FSLIT("Ptr") ptrTyConKey +funPtrTyConName = tcQual gHC_PTR FSLIT("FunPtr") funPtrTyConKey -- Foreign objects and weak pointers -stablePtrTyConName = tcQual pREL_STABLE FSLIT("StablePtr") stablePtrTyConKey -newStablePtrName = varQual pREL_STABLE FSLIT("newStablePtr") newStablePtrIdKey +stablePtrTyConName = tcQual gHC_STABLE FSLIT("StablePtr") stablePtrTyConKey +newStablePtrName = varQual gHC_STABLE FSLIT("newStablePtr") newStablePtrIdKey -- PrelST module -runSTRepName = varQual pREL_ST FSLIT("runSTRep") runSTRepIdKey +runSTRepName = varQual gHC_ST FSLIT("runSTRep") runSTRepIdKey -- The "split" Id for splittable implicit parameters splittableClassName = clsQual gLA_EXTS FSLIT("Splittable") splittableClassKey diff --git a/compiler/prelude/TysWiredIn.lhs b/compiler/prelude/TysWiredIn.lhs index ceb4df5..8a5c3ba 100644 --- a/compiler/prelude/TysWiredIn.lhs +++ b/compiler/prelude/TysWiredIn.lhs @@ -128,25 +128,25 @@ mkWiredInDataConName built_in mod fs uniq datacon parent (ADataCon datacon) -- Relevant DataCon built_in -charTyConName = mkWiredInTyConName UserSyntax pREL_BASE FSLIT("Char") charTyConKey charTyCon -charDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("C#") charDataConKey charDataCon charTyConName -intTyConName = mkWiredInTyConName UserSyntax pREL_BASE FSLIT("Int") intTyConKey intTyCon -intDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("I#") intDataConKey intDataCon intTyConName +charTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Char") charTyConKey charTyCon +charDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("C#") charDataConKey charDataCon charTyConName +intTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Int") intTyConKey intTyCon +intDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("I#") intDataConKey intDataCon intTyConName -boolTyConName = mkWiredInTyConName UserSyntax pREL_BASE FSLIT("Bool") boolTyConKey boolTyCon -falseDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("False") falseDataConKey falseDataCon boolTyConName -trueDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("True") trueDataConKey trueDataCon boolTyConName -listTyConName = mkWiredInTyConName BuiltInSyntax pREL_BASE FSLIT("[]") listTyConKey listTyCon -nilDataConName = mkWiredInDataConName BuiltInSyntax pREL_BASE FSLIT("[]") nilDataConKey nilDataCon listTyConName -consDataConName = mkWiredInDataConName BuiltInSyntax pREL_BASE FSLIT(":") consDataConKey consDataCon listTyConName +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 +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 -floatTyConName = mkWiredInTyConName UserSyntax pREL_FLOAT FSLIT("Float") floatTyConKey floatTyCon -floatDataConName = mkWiredInDataConName UserSyntax pREL_FLOAT FSLIT("F#") floatDataConKey floatDataCon floatTyConName -doubleTyConName = mkWiredInTyConName UserSyntax pREL_FLOAT FSLIT("Double") doubleTyConKey doubleTyCon -doubleDataConName = mkWiredInDataConName UserSyntax pREL_FLOAT FSLIT("D#") doubleDataConKey doubleDataCon doubleTyConName +floatTyConName = mkWiredInTyConName UserSyntax gHC_FLOAT FSLIT("Float") floatTyConKey floatTyCon +floatDataConName = mkWiredInDataConName UserSyntax gHC_FLOAT FSLIT("F#") floatDataConKey floatDataCon floatTyConName +doubleTyConName = mkWiredInTyConName UserSyntax gHC_FLOAT FSLIT("Double") doubleTyConKey doubleTyCon +doubleDataConName = mkWiredInDataConName UserSyntax gHC_FLOAT FSLIT("D#") doubleDataConKey doubleDataCon doubleTyConName -parrTyConName = mkWiredInTyConName BuiltInSyntax pREL_PARR FSLIT("[::]") parrTyConKey parrTyCon -parrDataConName = mkWiredInDataConName UserSyntax pREL_PARR FSLIT("PArr") parrDataConKey parrDataCon parrTyConName +parrTyConName = mkWiredInTyConName BuiltInSyntax gHC_PARR FSLIT("[::]") parrTyConKey parrTyCon +parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR FSLIT("PArr") parrDataConKey parrDataCon parrTyConName boolTyCon_RDR = nameRdrName boolTyConName false_RDR = nameRdrName falseDataConName @@ -537,7 +537,7 @@ mkPArrFakeCon arity = data_con tyvar = head alphaTyVars tyvarTys = replicate arity $ mkTyVarTy tyvar nameStr = mkFastString ("MkPArr" ++ show arity) - name = mkWiredInName pREL_PARR (mkOccNameFS dataName nameStr) uniq + name = mkWiredInName gHC_PARR (mkOccNameFS dataName nameStr) uniq Nothing (ADataCon data_con) UserSyntax uniq = mkPArrDataConUnique arity diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 3ee46a8..56fde05 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -33,7 +33,7 @@ module CostCentre ( import Var ( Id ) import Name ( getOccName, occNameFS ) -import Module ( Module, moduleFS ) +import Module ( Module ) import Outputable import FastTypes import FastString @@ -339,12 +339,12 @@ instance Outputable CostCentre where -- Printing in an interface file or in Core generally pprCostCentreCore (AllCafsCC {cc_mod = m}) - = text "__sccC" <+> braces (ppr_mod m) + = text "__sccC" <+> braces (ppr m) pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = caf, cc_is_dupd = dup}) = text "__scc" <+> braces (hsep [ ftext (zEncodeFS n), - ppr_mod m, + ppr m, pp_dup dup, pp_caf caf ]) @@ -355,13 +355,11 @@ pp_dup other = empty pp_caf CafCC = text "__C" pp_caf other = empty -ppr_mod m = ftext (zEncodeFS (moduleFS m)) - -- Printing as a C label ppCostCentreLbl (NoCostCentre) = text "NONE_cc" ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) - = ppr_mod m <> ftext (zEncodeFS n) <> + = ppr m <> ftext (zEncodeFS n) <> text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc" -- This is the name to go in the user-displayed string, diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index c95db9c..8e02892 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -29,12 +29,15 @@ module SCCfinal ( stgMassageForProfiling ) where import StgSyn -import Packages ( HomeModules ) +import PackageConfig ( PackageId ) import StaticFlags ( opt_AutoSccsOnIndividualCafs ) import CostCentre -- lots of things import Id ( Id ) import Module ( Module ) -import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply ) +import UniqSupply ( splitUniqSupply, UniqSupply ) +#ifdef PROF_DO_BOXING +import UniqSupply ( uniqFromSupply ) +#endif import Unique ( Unique ) import VarSet import ListSetOps ( removeDups ) @@ -45,13 +48,13 @@ infixr 9 `thenMM`, `thenMM_` \begin{code} stgMassageForProfiling - :: HomeModules + :: PackageId -> Module -- module name -> UniqSupply -- unique supply -> [StgBinding] -- input -> (CollectedCCs, [StgBinding]) -stgMassageForProfiling pdeps mod_name us stg_binds +stgMassageForProfiling this_pkg mod_name us stg_binds = let ((local_ccs, extern_ccs, cc_stacks), stg_binds2) @@ -102,7 +105,7 @@ stgMassageForProfiling pdeps mod_name us stg_binds do_top_rhs :: Id -> StgRhs -> MassageM StgRhs do_top_rhs binder (StgRhsClosure _ bi fv u srt [] (StgSCC cc (StgConApp con args))) - | not (isSccCountCostCentre cc) && not (isDllConApp pdeps con args) + | not (isSccCountCostCentre cc) && not (isDllConApp this_pkg con args) -- Trivial _scc_ around nothing but static data -- Eliminate _scc_ ... and turn into StgRhsCon @@ -358,8 +361,10 @@ mapAccumMM f b (m:ms) mapAccumMM f b2 ms `thenMM` \ (b3, rs) -> returnMM (b3, r:rs) +#ifdef PROF_DO_BOXING getUniqueMM :: MassageM Unique getUniqueMM mod scope_cc us ids ccs = (ccs, uniqFromSupply us) +#endif addTopLevelIshId :: Id -> MassageM a -> MassageM a addTopLevelIshId id scope mod scope_cc us ids ccs diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 2be3bfd..1c5a559 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -30,13 +30,14 @@ module RnEnv ( #include "HsVersions.h" -import LoadIface ( loadHomeInterface, loadSrcInterface ) +import LoadIface ( loadInterfaceForName, loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable, LHsTyVarBndr, LHsType, Fixity, hsLTyVarLocNames, replaceTyVarName ) import RdrHsSyn ( extractHsTyRdrTyVars ) -import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig, +import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe, + isQual_maybe, mkRdrUnqual, setRdrNameSpace, rdrNameOcc, pprGlobalRdrEnv, lookupGRE_RdrName, isExact_maybe, isSrcRdrName, @@ -52,7 +53,7 @@ import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, import NameSet import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace, reportIfUnused ) -import Module ( Module ) +import Module ( Module, ModuleName ) import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply import BasicTypes ( IPName, mapIPName ) @@ -91,7 +92,7 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) returnM name - | isOrig rdr_name + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) (badOrigBinding rdr_name) -- When reading External Core we get Orig names as binders, @@ -111,13 +112,11 @@ 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 (rdrNameOcc rdr_name) mb_parent + newGlobalBinder rdr_mod rdr_occ mb_parent (srcSpanStart loc) --TODO, should pass the whole span | otherwise = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) - where - rdr_mod = rdrNameModule rdr_name \end{code} %********************************************************* @@ -164,13 +163,12 @@ lookupTopBndrRn rdr_name | Just name <- isExact_maybe rdr_name = returnM name - | isOrig rdr_name + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name -- This deals with the case of derived bindings, where -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name = do { loc <- getSrcSpanM - ; newGlobalBinder (rdrNameModule rdr_name) - (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) } + ; newGlobalBinder rdr_mod rdr_occ Nothing (srcSpanStart loc) } | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name @@ -278,9 +276,12 @@ lookupImportedName rdr_name -- This happens in derived code = returnM n - | otherwise -- Always Orig, even when reading a .hi-boot file - = ASSERT( not (isUnqual rdr_name) ) - lookupOrig (rdrNameModule rdr_name) (rdrNameOcc rdr_name) + -- Always Orig, even when reading a .hi-boot file + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name + = lookupOrig rdr_mod rdr_occ + + | otherwise + = pprPanic "RnEnv.lookupImportedName" (ppr rdr_name) unboundName :: RdrName -> RnM Name unboundName rdr_name @@ -337,13 +338,10 @@ lookupGreRn_help rdr_name lookup -- try to load the interface if we don't already have it. lookupQualifiedName :: RdrName -> RnM Name lookupQualifiedName rdr_name - = let - mod = rdrNameModule rdr_name - occ = rdrNameOcc rdr_name - in + | Just (mod,occ) <- isQual_maybe rdr_name -- Note: we want to behave as we would for a source file import here, -- and respect hiddenness of modules/packages, hence loadSrcInterface. - loadSrcInterface doc mod False `thenM` \ iface -> + = loadSrcInterface doc mod False `thenM` \ iface -> case [ (mod,occ) | (mod,avails) <- mi_exports iface, @@ -353,6 +351,9 @@ lookupQualifiedName rdr_name ((mod,occ):ns) -> ASSERT (null ns) lookupOrig mod occ _ -> unboundName rdr_name + + | otherwise + = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) where doc = ptext SLIT("Need to find") <+> ppr rdr_name \end{code} @@ -421,7 +422,7 @@ lookupFixityRn name else -- It's imported -- For imported names, we have to get their fixities by doing a - -- loadHomeInterface, and consulting the Ifaces that comes back + -- loadInterfaceForName, and consulting the Ifaces that comes back -- from that, because the interface file for the Name might not -- have been loaded yet. Why not? Suppose you import module A, -- which exports a function 'f', thus; @@ -434,9 +435,9 @@ lookupFixityRn name -- 'f', we need to know its fixity, and it's then, and only -- then, that we load B.hi. That is what's happening here. -- - -- loadHomeInterface will find B.hi even if B is a hidden module, + -- loadInterfaceForName will find B.hi even if B is a hidden module, -- and that's what we want. - loadHomeInterface doc name `thenM` \ iface -> + loadInterfaceForName doc name `thenM` \ iface -> returnM (mi_fix_fn iface (nameOccName name)) where doc = ptext SLIT("Checking fixity for") <+> ppr name @@ -705,7 +706,7 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [(Module,SrcSpan)] -> RnM () +warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 87af074..e968590 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -44,7 +44,7 @@ import Name ( isTyVarName ) import Name ( Name, nameOccName, nameIsLocalOrFrom ) import NameSet import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv ) -import LoadIface ( loadHomeInterface ) +import LoadIface ( loadInterfaceForName ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) import List ( nub ) @@ -550,7 +550,7 @@ rnRbinds str rbinds rnBracket (VarBr n) = do { name <- lookupOccRn n ; this_mod <- getModule ; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the - do { loadHomeInterface msg name -- home interface is loaded, and this is the + do { loadInterfaceForName msg name -- home interface is loaded, and this is the ; return () } -- only way that is going to happen ; returnM (VarBr name, unitFV name) } where diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index 658028c..71d5c9b 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -13,7 +13,7 @@ module RnNames ( #include "HsVersions.h" -import DynFlags ( DynFlag(..), GhcMode(..) ) +import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) ) import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, ForeignDecl(..), HsGroup(..), HsValBinds(..), Sig(..), collectHsBindLocatedBinders, tyClDeclNames, @@ -24,9 +24,8 @@ import LoadIface ( loadSrcInterface ) import TcRnMonad hiding (LIE) import FiniteMap -import PrelNames ( pRELUDE, isUnboundName, main_RDR_Unqual ) -import Module ( Module, moduleString, unitModuleEnv, - lookupModuleEnv, moduleEnvElts, foldModuleEnv ) +import PrelNames +import Module import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName, nameParent, nameParent_maybe, isExternalName, isBuiltInSyntax ) @@ -38,11 +37,10 @@ import OccName ( srcDataName, isTcOcc, pprNonVarNameSpace, extendOccEnv ) import HscTypes ( GenAvailInfo(..), AvailInfo, HomePackageTable, PackageIfaceTable, - unQualInScope, + mkPrintUnqualified, Deprecs(..), ModIface(..), Dependencies(..), - lookupIface, ExternalPackageState(..) + lookupIfaceByModule, ExternalPackageState(..) ) -import Packages ( PackageIdH(..) ) import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), emptyGlobalRdrEnv, plusGlobalRdrEnv, globalRdrEnvElts, @@ -50,6 +48,7 @@ import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), importSpecLoc, importSpecModule, isLocalGRE, pprNameProvenance ) import Outputable +import UniqFM import Maybes ( isNothing, catMaybes, mapCatMaybes, seqMaybe, orElse ) import SrcLoc ( Located(..), mkGeneralSrcSpan, unLoc, noLoc, srcLocSpan, SrcSpan ) @@ -96,12 +95,12 @@ rnImports imports | otherwise = [preludeImportDecl] explicit_prelude_import = notNull [ () | L _ (ImportDecl mod _ _ _ _) <- imports, - unLoc mod == pRELUDE ] + unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl RdrName preludeImportDecl = L loc $ - ImportDecl (L loc pRELUDE) + ImportDecl (L loc pRELUDE_NAME) False {- Not a boot interface -} False {- Not qualified -} Nothing {- No "as" -} @@ -271,13 +270,14 @@ importsFromImportDecl this_mod let -- Compute new transitive dependencies - orphans | is_orph = ASSERT( not (imp_mod_name `elem` dep_orphs deps) ) - imp_mod_name : dep_orphs deps + orphans | is_orph = ASSERT( not (imp_mod `elem` dep_orphs deps) ) + imp_mod : dep_orphs deps | otherwise = dep_orphs deps + pkg = modulePackageId (mi_module iface) + (dependent_mods, dependent_pkgs) - = case mi_package iface of - HomePackage -> + | pkg == thisPackage dflags = -- Imported module is from the home package -- Take its dependent modules and add imp_mod itself -- Take its dependent packages unchanged @@ -291,7 +291,7 @@ importsFromImportDecl this_mod -- check. See LoadIface.loadHiBootInterface ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps) - ExtPackage pkg -> + | otherwise = -- Imported module is from another package -- Dump the dependent modules -- Add the package imp_mod comes from to the dependent packages @@ -308,7 +308,7 @@ importsFromImportDecl this_mod -- module M ( module P ) where ... -- Then we must export whatever came from P unqualified. imports = ImportAvails { - imp_env = unitModuleEnv qual_mod_name avail_env, + imp_env = unitUFM qual_mod_name avail_env, imp_mods = unitModuleEnv imp_mod (imp_mod, import_all, loc), imp_orphs = orphans, imp_dep_mods = mkModDeps dependent_mods, @@ -376,7 +376,7 @@ importsFromLocalDecls group ; this_mod = tcg_mod gbl_env ; imports = emptyImportAvails { - imp_env = unitModuleEnv this_mod $ + imp_env = unitUFM (moduleName this_mod) $ mkNameSet filtered_names } } @@ -544,7 +544,7 @@ 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 - = ([Module], -- 'module M's seen so far + = ([ModuleName], -- 'module M's seen so far ExportOccMap, -- Tracks exported occurrence names NameSet) -- The accumulated exported stuff emptyExportAccum = ([], emptyOccEnv, emptyNameSet) @@ -561,7 +561,7 @@ 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 (foldModuleEnv unionNameSets emptyNameSet imp_env) + sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env) rnExport (IEVar rdrName) = do name <- lookupGlobalOccRn rdrName return (IEVar name) @@ -631,7 +631,7 @@ exports_from_avail (Just (items,origItems)) rdr_env (ImportAvails { imp_env = im return exports where sub_env :: NameEnv [Name] -- Classify each name by its parent - sub_env = mkSubNameEnv (foldModuleEnv unionNameSets emptyNameSet imp_env) + sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env) do_litem :: ExportAccum -> (LIE Name, LIE RdrName) -> RnM ExportAccum do_litem acc (ieName, ieRdr) @@ -645,7 +645,7 @@ exports_from_avail (Just (items,origItems)) rdr_env (ImportAvails { imp_env = im returnM acc } | otherwise - = case lookupModuleEnv imp_env mod of + = case lookupUFM imp_env mod of Nothing -> do addErr (modExportErr mod) return acc Just names @@ -738,8 +738,8 @@ check_occs ie occs names %********************************************************* \begin{code} -reportDeprecations :: TcGblEnv -> RnM () -reportDeprecations tcg_env +reportDeprecations :: DynFlags -> TcGblEnv -> RnM () +reportDeprecations dflags tcg_env = ifOptM Opt_WarnDeprecations $ do { (eps,hpt) <- getEpsAndHpt -- By this time, typechecking is complete, @@ -752,7 +752,7 @@ reportDeprecations tcg_env check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_)}) | name `elemNameSet` used_names - , Just deprec_txt <- lookupDeprec hpt pit name + , Just deprec_txt <- lookupDeprec dflags hpt pit name = setSrcSpan (importSpecLoc imp_spec) $ addWarn (sep [ptext SLIT("Deprecated use of") <+> pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> @@ -763,7 +763,7 @@ reportDeprecations tcg_env name_mod = nameModule name imp_mod = importSpecModule imp_spec imp_msg = ptext SLIT("imported from") <+> ppr imp_mod <> extra - extra | imp_mod == name_mod = empty + extra | imp_mod == moduleName name_mod = empty | otherwise = ptext SLIT(", but defined in") <+> ppr name_mod check hpt pit ok_gre = returnM () -- Local, or not used, or not deprectated @@ -774,10 +774,10 @@ reportDeprecations tcg_env -- the defn of a non-deprecated thing, when changing a module's -- interface -lookupDeprec :: HomePackageTable -> PackageIfaceTable +lookupDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable -> Name -> Maybe DeprecTxt -lookupDeprec hpt pit n - = case lookupIface hpt pit (nameModule n) of +lookupDeprec dflags hpt pit 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 Nothing @@ -854,7 +854,7 @@ reportUnusedNames export_decls gbl_env -- into a bunch of avails, so they are properly grouped -- -- BUG WARNING: this does not deal properly with qualified imports! - minimal_imports :: FiniteMap Module AvailEnv + minimal_imports :: FiniteMap ModuleName AvailEnv minimal_imports0 = foldr add_expall emptyFM expall_mods minimal_imports1 = foldr add_name minimal_imports0 defined_and_used minimal_imports = foldr add_inst_mod minimal_imports1 direct_import_mods @@ -909,9 +909,10 @@ reportUnusedNames export_decls gbl_env | otherwise = Avail n add_inst_mod (mod,_,_) acc - | mod `elemFM` acc = acc -- We import something already - | otherwise = addToFM acc mod emptyAvailEnv + | mod_name `elemFM` acc = acc -- We import something already + | otherwise = addToFM acc mod_name emptyAvailEnv where + mod_name = moduleName mod -- Add an empty collection of imports for a module -- from which we have sucked only instance decls @@ -928,15 +929,16 @@ reportUnusedNames export_decls gbl_env -- -- BUG WARNING: does not deal correctly with multiple imports of the same module -- becuase direct_import_mods has only one entry per module - unused_imp_mods = [(mod,loc) | (mod,no_imp,loc) <- direct_import_mods, - not (mod `elemFM` minimal_imports1), + unused_imp_mods = [(mod_name,loc) | (mod,no_imp,loc) <- direct_import_mods, + let mod_name = moduleName mod, + not (mod_name `elemFM` minimal_imports1), mod /= pRELUDE, not no_imp] -- The not no_imp part is not to complain about -- import M (), which is an idiom for importing -- instance declarations - module_unused :: Module -> Bool + module_unused :: ModuleName -> Bool module_unused mod = any (((==) mod) . fst) unused_imp_mods --------------------- @@ -1017,7 +1019,7 @@ selectiveImpItem ImpAll = False selectiveImpItem (ImpSome {}) = True -- ToDo: deal with original imports with 'qualified' and 'as M' clauses -printMinimalImports :: FiniteMap Module AvailEnv -- Minimal imports +printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports -> RnM () printMinimalImports imps = ifOptM Opt_D_dump_minimal_imports $ do { @@ -1026,13 +1028,13 @@ printMinimalImports imps this_mod <- getModule ; rdr_env <- getGlobalRdrEnv ; ioToTcRn (do { h <- openFile (mkFilename this_mod) WriteMode ; - printForUser h (unQualInScope rdr_env) + printForUser h (mkPrintUnqualified rdr_env) (vcat (map ppr_mod_ie mod_ies)) }) } where - mkFilename this_mod = moduleString this_mod ++ ".imports" + mkFilename this_mod = moduleNameString (moduleName this_mod) ++ ".imports" ppr_mod_ie (mod_name, ies) - | mod_name == pRELUDE + | mod_name == moduleName pRELUDE = empty | null ies -- Nothing except instances comes from here = ptext SLIT("import") <+> ppr mod_name <> ptext SLIT("() -- Instances only") @@ -1053,7 +1055,7 @@ printMinimalImports imps to_ie (AvailTC n ns) = loadSrcInterface doc n_mod False `thenM` \ iface -> case [xs | (m,as) <- mi_exports iface, - m == n_mod, + moduleName m == n_mod, AvailTC x xs <- as, x == nameOccName n] of [xs] | all_used xs -> returnM (IEThingAll n) @@ -1063,7 +1065,7 @@ printMinimalImports imps where all_used avail_occs = all (`elem` map nameOccName ns) avail_occs doc = text "Compute minimal imports from" <+> ppr n - n_mod = nameModule n + n_mod = moduleName (nameModule n) \end{code} diff --git a/compiler/simplStg/SimplStg.lhs b/compiler/simplStg/SimplStg.lhs index e87877c..a7b2239 100644 --- a/compiler/simplStg/SimplStg.lhs +++ b/compiler/simplStg/SimplStg.lhs @@ -16,7 +16,6 @@ import StgLint ( lintStgBindings ) import StgStats ( showStgStats ) import SRT ( computeSRTs ) -import Packages ( HomeModules ) import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..), getStgToDo ) import Id ( Id ) @@ -28,13 +27,12 @@ import Outputable \begin{code} stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do - -> HomeModules -> Module -- module name (profiling only) -> [StgBinding] -- input... -> IO ( [(StgBinding,[(Id,[Id])])] -- output program... , CollectedCCs) -- cost centre information (declared and used) -stg2stg dflags pkg_deps module_name binds +stg2stg dflags module_name binds = do { showPass dflags "Stg2Stg" ; us <- mkSplitUniqSupply 'g' @@ -74,7 +72,8 @@ stg2stg dflags pkg_deps module_name binds {-# SCC "ProfMassage" #-} let (collected_CCs, binds3) - = stgMassageForProfiling pkg_deps module_name us1 binds + = stgMassageForProfiling this_pkg module_name us1 binds + this_pkg = thisPackage dflags in end_pass us2 "ProfMassage" collected_CCs binds3 diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 824caba..50b2973 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -32,8 +32,8 @@ import Maybes ( maybeToBool ) import Name ( getOccName, isExternalName, nameOccName ) import OccName ( occNameString, occNameFS ) import BasicTypes ( Arity ) -import Packages ( HomeModules ) import StaticFlags ( opt_RuntimeTypes ) +import PackageConfig ( PackageId ) import Outputable infixr 9 `thenLne` @@ -140,10 +140,10 @@ for x, solely to put in the SRTs lower down. %************************************************************************ \begin{code} -coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding] -coreToStg hmods pgm +coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding] +coreToStg this_pkg pgm = return pgm' - where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm + where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm coreExprToStg :: CoreExpr -> StgExpr coreExprToStg expr @@ -151,35 +151,35 @@ coreExprToStg expr coreTopBindsToStg - :: HomeModules + :: PackageId -> IdEnv HowBound -- environment for the bindings -> [CoreBind] -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) -coreTopBindsToStg hmods env [] = (env, emptyFVInfo, []) -coreTopBindsToStg hmods env (b:bs) +coreTopBindsToStg this_pkg env [] = (env, emptyFVInfo, []) +coreTopBindsToStg this_pkg env (b:bs) = (env2, fvs2, b':bs') where -- env accumulates down the list of binds, fvs accumulates upwards - (env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b - (env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs + (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b + (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs coreTopBindToStg - :: HomeModules + :: PackageId -> IdEnv HowBound -> FreeVarsInfo -- Info about the body -> CoreBind -> (IdEnv HowBound, FreeVarsInfo, StgBinding) -coreTopBindToStg hmods env body_fvs (NonRec id rhs) +coreTopBindToStg this_pkg env body_fvs (NonRec id rhs) = let env' = extendVarEnv env id how_bound how_bound = LetBound TopLet $! manifestArity rhs (stg_rhs, fvs') = initLne env ( - coreToTopStgRhs hmods body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> + coreToTopStgRhs this_pkg body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> returnLne (stg_rhs, fvs') ) @@ -190,7 +190,7 @@ coreTopBindToStg hmods env body_fvs (NonRec id rhs) -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) (env', fvs' `unionFVInfo` body_fvs, bind) -coreTopBindToStg hmods env body_fvs (Rec pairs) +coreTopBindToStg this_pkg env body_fvs (Rec pairs) = let (binders, rhss) = unzip pairs @@ -200,7 +200,7 @@ coreTopBindToStg hmods env body_fvs (Rec pairs) (stg_rhss, fvs') = initLne env' ( - mapAndUnzipLne (coreToTopStgRhs hmods body_fvs) pairs + mapAndUnzipLne (coreToTopStgRhs this_pkg body_fvs) pairs `thenLne` \ (stg_rhss, fvss') -> let fvs' = unionFVInfos fvss' in returnLne (stg_rhss, fvs') @@ -232,18 +232,18 @@ consistentCafInfo id bind \begin{code} coreToTopStgRhs - :: HomeModules + :: PackageId -> FreeVarsInfo -- Free var info for the scope of the binding -> (Id,CoreExpr) -> LneM (StgRhs, FreeVarsInfo) -coreToTopStgRhs hmods scope_fv_info (bndr, rhs) +coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs) = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) -> freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info -> returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs) where bndr_info = lookupFVInfo scope_fv_info bndr - is_static = rhsIsStatic hmods rhs + is_static = rhsIsStatic this_pkg rhs mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index f1c50cc..74832a2 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -52,6 +52,7 @@ import Var ( isId ) import Id ( Id, idName, idType, idCafInfo ) import IdInfo ( mayHaveCafRefs ) import Packages ( isDllName ) +import PackageConfig ( PackageId ) import Literal ( Literal, literalType ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) @@ -65,8 +66,6 @@ import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) import Unique ( Unique ) import Bitmap -import DynFlags ( DynFlags ) -import Packages ( HomeModules ) import StaticFlags ( opt_SccProfilingOn ) \end{code} @@ -106,18 +105,18 @@ data GenStgArg occ isStgTypeArg (StgTypeArg _) = True isStgTypeArg other = False -isDllArg :: HomeModules -> StgArg -> Bool +isDllArg :: PackageId -> StgArg -> Bool -- Does this argument refer to something in a different DLL? -isDllArg hmods (StgTypeArg v) = False -isDllArg hmods (StgVarArg v) = isDllName hmods (idName v) -isDllArg hmods (StgLitArg lit) = False +isDllArg this_pkg (StgTypeArg v) = False +isDllArg this_pkg (StgVarArg v) = isDllName this_pkg (idName v) +isDllArg this_pkg (StgLitArg lit) = False -isDllConApp :: HomeModules -> DataCon -> [StgArg] -> Bool +isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool -- Does this constructor application refer to -- anything in a different DLL? -- If so, we can't allocate it statically -isDllConApp hmods con args - = isDllName hmods (dataConName con) || any (isDllArg hmods) args +isDllConApp this_pkg con args + = isDllName this_pkg (dataConName con) || any (isDllArg this_pkg) args stgArgType :: StgArg -> Type -- Very half baked becase we have lost the type arguments diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 8768e20..77ca56a 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -68,9 +68,9 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcPredType, import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst, notElemTvSubst, extendTvSubstList ) import Unify ( tcMatchTys ) +import Module ( modulePackageId ) import Kind ( isSubKind ) -import Packages ( isHomeModule ) -import HscTypes ( ExternalPackageState(..) ) +import HscTypes ( ExternalPackageState(..), HscEnv(..) ) import CoreFVs ( idFreeTyVars ) import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId ) import Id ( Id, idName, idType, mkUserLocal, mkLocalId ) @@ -86,7 +86,7 @@ import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rational import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) -import DynFlags ( DynFlag(..), dopt ) +import DynFlags ( DynFlag(..), DynFlags(..), dopt ) import Maybes ( isJust ) import Outputable \end{code} @@ -698,11 +698,11 @@ lookupPred pred@(ClassP clas tys) lookupPred ip_pred = return Nothing record_dfun_usage dfun_id - = do { gbl <- getGblEnv + = do { hsc_env <- getTopEnv ; let dfun_name = idName dfun_id dfun_mod = nameModule dfun_name ; if isInternalName dfun_name || -- Internal name => defined in this module - not (isHomeModule (tcg_home_mods gbl) dfun_mod) + modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env) then return () -- internal, or in another package else do { tcg_env <- getGblEnv ; updMutVar (tcg_inst_uses tcg_env) diff --git a/compiler/typecheck/TcEnv.lhs b/compiler/typecheck/TcEnv.lhs index d8058d5..be1ce9b 100644 --- a/compiler/typecheck/TcEnv.lhs +++ b/compiler/typecheck/TcEnv.lhs @@ -104,7 +104,8 @@ tcLookupGlobal name -- Try global envt { (eps,hpt) <- getEpsAndHpt - ; case lookupType hpt (eps_PTE eps) name of { + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of { Just thing -> return thing ; Nothing -> do diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index fc38fd5..7adb9d5 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -26,7 +26,6 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) import StaticFlags ( opt_PprStyle_Debug ) -import Packages ( checkForPackageConflicts, mkHomeModules ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), LHsBinds, emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds, @@ -63,7 +62,8 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv ) +import Module +import UniqFM ( elemUFM, eltsUFM ) import OccName ( mkVarOccFS, plusOccEnv ) import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, mkExternalName ) @@ -103,9 +103,8 @@ import RnTypes ( rnLHsType ) import Inst ( tcGetInstEnvs ) import InstEnv ( classInstances, instEnvElts ) import RnExpr ( rnStmts, rnLExpr ) -import LoadIface ( loadSrcInterface, loadSysInterface ) +import LoadIface ( loadSysInterface ) import IfaceEnv ( ifaceExportNames ) -import Module ( moduleSetElts, mkModuleSet ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( setIdType ) import MkId ( unsafeCoerceId ) @@ -127,11 +126,10 @@ import SrcLoc ( unLoc ) #endif import FastString ( mkFastString ) -import Maybes ( MaybeErr(..) ) import Util ( sortLe ) import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) -import Maybe ( isJust ) +import Data.Maybe ( isJust, isNothing ) \end{code} @@ -155,9 +153,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax import_decls local_decls mod_deprec)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - let { this_mod = case maybe_mod of - Nothing -> mAIN -- 'module M where' is omitted - Just (L _ mod) -> mod } ; -- The normal case + let { this_pkg = thisPackage (hsc_dflags hsc_env) ; + this_mod = case maybe_mod of + Nothing -> mAIN -- 'module M where' is omitted + Just (L _ mod) -> mkModule this_pkg mod } ; + -- The normal case initTc hsc_env hsc_src this_mod $ setSrcSpan loc $ @@ -166,16 +166,16 @@ tcRnModule hsc_env hsc_src save_rn_syntax rn_imports <- rnImports import_decls ; (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ; - let { dep_mods :: ModuleEnv (Module, IsBootInterface) + let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports -- We want instance declarations from all home-package -- modules below this one, including boot modules, except -- ourselves. The 'except ourselves' is so that we don't -- get the instances from this module's hs-boot file - ; want_instances :: Module -> Bool - ; want_instances mod = mod `elemModuleEnv` dep_mods - && mod /= this_mod + ; want_instances :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod ; home_insts = hptInstances hsc_env want_instances } ; @@ -184,8 +184,6 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- and any other incrementally-performed imports updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; - checkConflicts imports this_mod $ do { - -- Update the gbl env updGblEnv ( \ gbl -> gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, @@ -226,7 +224,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- that we don't bleat about re-exporting a deprecated -- thing (especially via 'module Foo' export item) -- Only uses in the body of the module are complained about - reportDeprecations tcg_env ; + reportDeprecations (hsc_dflags hsc_env) tcg_env ; -- Process the export list rn_exports <- rnExports export_ies ; @@ -254,27 +252,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- Dump output and return tcDump final_env ; return final_env - }}}}} - - --- The program is not allowed to contain two modules with the same --- name, and we check for that here. It could happen if the home package --- contains a module that is also present in an external package, for example. -checkConflicts imports this_mod and_then = do - dflags <- getDOpts - let - dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports)) - -- don't forget to include the current module! - - mb_dep_pkgs = checkForPackageConflicts - dflags dep_mods (imp_dep_pkgs imports) - -- - case mb_dep_pkgs of - Failed msg -> - do addErr msg; failM - Succeeded _ -> - updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods }) - and_then + }}}} \end{code} @@ -333,7 +311,6 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_usages = [], -- ToDo: compute usage mg_dir_imps = [], -- ?? mg_deps = noDependencies, -- ?? - mg_home_mods = mkHomeModules [], -- ?? wrong!! mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, @@ -1128,17 +1105,13 @@ getModuleExports hsc_env mod tcGetModuleExports :: Module -> TcM NameSet tcGetModuleExports mod = do - iface <- load_iface mod + let doc = ptext SLIT("context for compiling statements") + iface <- initIfaceTcRn $ loadSysInterface doc mod loadOrphanModules (dep_orphs (mi_deps iface)) -- Load any orphan-module interfaces, -- so their instances are visible ifaceExportNames (mi_exports iface) -load_iface mod = loadSrcInterface doc mod False {- Not boot iface -} - where - doc = ptext SLIT("context for compiling statements") - - tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name = initTcPrintErrors hsc_env iNTERACTIVE $ @@ -1239,7 +1212,9 @@ plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualif = all ok (nameSetToList (tyClsNamesOfType (idType dfun))) where ok name | isBuiltInSyntax name = True - | isExternalName name = print_unqual (nameModule name) (nameOccName name) + | isExternalName name = + isNothing $ fst print_unqual (nameModule name) + (nameOccName name) | otherwise = True loadUnqualIfaces :: InteractiveContext -> TcM () @@ -1308,7 +1283,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, , ppr_insts dfun_ids , vcat (map ppr rules) , ppr_gen_tycons (typeEnvTyCons type_env) - , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports)) + , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)] pprModGuts :: ModGuts -> SDoc diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index ee3c6c6..f515334 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -11,7 +11,7 @@ import TcRnTypes -- Re-export all import IOEnv -- Re-export all #if defined(GHCI) && defined(BREAKPOINT) -import TypeRep ( Type(..), liftedTypeKind, TyThing(..) ) +import TypeRep ( Type(..), liftedTypeKind ) import Var ( mkTyVar, mkGlobalId ) import IdInfo ( GlobalIdDetails(..), vanillaIdInfo ) import OccName ( mkOccName, tvName ) @@ -23,14 +23,13 @@ import NameEnv ( mkNameEnv ) import HsSyn ( emptyLHsBinds ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), - TyThing, TypeEnv, emptyTypeEnv, HscSource(..), - isHsBoot, ModSummary(..), + TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot, ExternalPackageState(..), HomePackageTable, Deprecs(..), FixityEnv, FixItem, - lookupType, unQualInScope ) -import Module ( Module, unitModuleEnv ) + mkPrintUnqualified ) +import Module ( Module, moduleName ) import RdrName ( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) -import Name ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc ) +import Name ( Name, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc ) import Type ( Type ) import TcType ( tcIsTyVarTy, tcGetTyVar ) import NameEnv ( extendNameEnvList, nameEnvElts ) @@ -42,7 +41,6 @@ import VarEnv ( TidyEnv, emptyTidyEnv, extendVarEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, mkWarnMsg, printErrorsAndWarnings, mkLocMessage, mkLongErrMsg ) -import Packages ( mkHomeModules ) import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) @@ -50,6 +48,7 @@ import OccName ( emptyOccEnv, tidyOccName ) import Bag ( emptyBag ) import Outputable import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) +import UniqFM ( unitUFM ) import Unique ( Unique ) import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode ) import StaticFlags ( opt_PprStyle_Debug ) @@ -105,7 +104,6 @@ initTc hsc_env hsc_src mod do_this tcg_th_used = th_var, tcg_exports = emptyNameSet, tcg_imports = init_imports, - tcg_home_mods = home_mods, tcg_dus = emptyDUs, tcg_rn_imports = Nothing, tcg_rn_exports = Nothing, @@ -174,17 +172,8 @@ initTc hsc_env hsc_src mod do_this return (msgs, final_res) } where - home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env)) - -- A guess at the home modules. This will be correct in - -- --make and GHCi modes, but in one-shot mode we need to - -- fix it up after we know the real dependencies of the current - -- module (see tcRnModule). - -- Setting it here is necessary for the typechecker entry points - -- other than tcRnModule: tcRnGetInfo, for example. These are - -- all called via the GHC module, so hsc_mod_graph will contain - -- something sensible. - - init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet} + init_imports = emptyImportAvails {imp_env = + unitUFM (moduleName mod) emptyNameSet} -- 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 @@ -199,15 +188,6 @@ initTcPrintErrors env mod todo = do (msgs, res) <- initTc env HsSrcFile mod todo printErrorsAndWarnings (hsc_dflags env) msgs return res - --- mkImpTypeEnv makes the imported symbol table -mkImpTypeEnv :: ExternalPackageState -> HomePackageTable - -> Name -> Maybe TyThing -mkImpTypeEnv pcs hpt = lookup - where - pte = eps_PTE pcs - lookup name | isInternalName name = Nothing - | otherwise = lookupType hpt pte name \end{code} @@ -395,7 +375,7 @@ traceOptTcRn flag doc = ifOptM flag $ do dumpTcRn :: SDoc -> TcRn () dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ; - ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) } + ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) } dumpOptTcRn :: DynFlag -> SDoc -> TcRn () dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc) @@ -493,7 +473,7 @@ addLongErrAt loc msg extra = do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ; + let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } @@ -509,7 +489,7 @@ addReportAt :: SrcSpan -> Message -> TcRn () addReportAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ; + let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) } diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index 4ad1b0d..3c3ca95 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -49,7 +49,7 @@ import HscTypes ( FixityEnv, HscEnv, TypeEnv, TyThing, GenAvailInfo(..), AvailInfo, HscSource(..), availName, IsBootInterface, Deprecations ) -import Packages ( PackageId, HomeModules ) +import Packages ( PackageId ) import Type ( Type, pprTyThingCategory ) import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo ) @@ -62,6 +62,7 @@ import NameSet ( NameSet, unionNameSets, DefUses ) import Var ( Id, TyVar ) import VarEnv ( TidyEnv ) import Module +import UniqFM import SrcLoc ( SrcSpan, SrcLoc, Located, srcSpanStart ) import VarSet ( IdSet ) import ErrUtils ( Messages, Message ) @@ -91,10 +92,9 @@ type TcId = Id -- Type may be a TcType type TcIdSet = IdSet type TcDictBinds = DictBinds TcId -- Bag of dictionary bindings - - type TcRnIf a b c = IOEnv (Env a b) c type IfM lcl a = TcRnIf IfGblEnv lcl a -- Iface stuff + type IfG a = IfM () a -- Top level type IfL a = IfM IfLclEnv a -- Nested type TcRn a = TcRnIf TcGblEnv TcLclEnv a @@ -115,7 +115,8 @@ data Env gbl lcl -- Changes as we move into an expression env_top :: HscEnv, -- Top-level stuff that never changes -- Includes all info about imported things - env_us :: TcRef UniqSupply, -- Unique supply for local varibles + env_us :: {-# UNPACK #-} !(IORef UniqSupply), + -- Unique supply for local varibles env_gbl :: gbl, -- Info about things defined at the top level -- of the module being compiled @@ -164,10 +165,6 @@ data TcGblEnv -- from where, including things bound -- in this module - tcg_home_mods :: HomeModules, - -- Calculated from ImportAvails, allows us to - -- call Packages.isHomeModule - tcg_dus :: DefUses, -- What is defined in this module and what is used. -- The latter is used to generate -- (a) version tracking; no need to recompile if these @@ -472,7 +469,7 @@ It is used * when processing the export list \begin{code} data ImportAvails = ImportAvails { - imp_env :: ModuleEnv NameSet, + imp_env :: ModuleNameEnv NameSet, -- All the things imported, classified by -- the *module qualifier* for its import -- e.g. import List as Foo @@ -501,7 +498,7 @@ data ImportAvails -- need to recompile if the export version changes -- (b) to specify what child modules to initialise - imp_dep_mods :: ModuleEnv (Module, IsBootInterface), + imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), -- Home-package modules needed by the module being compiled -- -- It doesn't matter whether any of these dependencies @@ -520,16 +517,16 @@ data ImportAvails -- Orphan modules below us in the import tree } -mkModDeps :: [(Module, IsBootInterface)] - -> ModuleEnv (Module, IsBootInterface) -mkModDeps deps = foldl add emptyModuleEnv deps +mkModDeps :: [(ModuleName, IsBootInterface)] + -> ModuleNameEnv (ModuleName, IsBootInterface) +mkModDeps deps = foldl add emptyUFM deps where - add env elt@(m,_) = extendModuleEnv env m elt + add env elt@(m,_) = addToUFM env m elt emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_env = emptyModuleEnv, +emptyImportAvails = ImportAvails { imp_env = emptyUFM, imp_mods = emptyModuleEnv, - imp_dep_mods = emptyModuleEnv, + imp_dep_mods = emptyUFM, imp_dep_pkgs = [], imp_orphs = [] } @@ -539,9 +536,9 @@ plusImportAvails imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_orphs = orphs1 }) (ImportAvails { imp_env = env2, imp_mods = mods2, imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2 }) - = ImportAvails { imp_env = plusModuleEnv_C unionNameSets env1 env2, + = ImportAvails { imp_env = plusUFM_C unionNameSets env1 env2, imp_mods = mods1 `plusModuleEnv` mods2, - imp_dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2, + imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, imp_orphs = orphs1 `unionLists` orphs2 } where diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 7c3aa86..cce4bec 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -41,7 +41,7 @@ import NameEnv ( lookupNameEnv ) import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails ) import OccName import Var ( Id, TyVar, idType ) -import Module ( moduleString ) +import Module ( moduleName, moduleNameString, modulePackageId ) import TcRnMonad import IfaceEnv ( lookupOrig ) import Class ( Class, classExtraBigSig ) @@ -59,7 +59,7 @@ import ErrUtils ( Message ) import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc ) import Outputable import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily ) - +import PackageConfig ( packageIdString ) import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) ) import Panic ( showException ) import FastString ( LitString ) @@ -419,7 +419,10 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where qReport True msg = addErr (text msg) qReport False msg = addReport (text msg) - qCurrentModule = do { m <- getModule; return (moduleString m) } + qCurrentModule = do { m <- getModule; + return (moduleNameString (moduleName m)) } + -- ToDo: is throwing away the package name ok here? + qReify v = reify v -- For qRecover, discard error messages if @@ -479,9 +482,9 @@ reify th_name ; reifyThing thing } where - ppr_ns (TH.Name _ (TH.NameG TH.DataName mod)) = text "data" - ppr_ns (TH.Name _ (TH.NameG TH.TcClsName mod)) = text "tc" - ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var" + ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data" + ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc" + ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var" lookupThName :: TH.Name -> TcM Name lookupThName th_name@(TH.Name occ flavour) @@ -524,7 +527,8 @@ tcLookupTh name else do -- It's imported { (eps,hpt) <- getEpsAndHpt - ; case lookupType hpt (eps_PTE eps) name of + ; dflags <- getDOpts + ; case lookupType dflags hpt (eps_PTE eps) name of Just thing -> return (AGlobal thing) Nothing -> do { thing <- tcImportDecl name ; return (AGlobal thing) } @@ -663,7 +667,7 @@ reifyPred p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p) ------------------------------ reifyName :: NamedThing n => n -> TH.Name reifyName thing - | isExternalName name = mk_varg mod occ_str + | isExternalName name = mk_varg pkg_str mod_str occ_str | otherwise = TH.mkNameU occ_str (getKey (getUnique name)) -- Many of the things we reify have local bindings, and -- NameL's aren't supposed to appear in binding positions, so @@ -671,7 +675,9 @@ reifyName thing -- have free variables, we may need to generate NameL's for them. where name = getName thing - mod = moduleString (nameModule name) + mod = nameModule name + pkg_str = packageIdString (modulePackageId mod) + mod_str = moduleNameString (moduleName mod) occ_str = occNameString occ occ = nameOccName name mk_varg | OccName.isDataOcc occ = TH.mkNameG_d diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs index cf99e12..52262ec 100644 --- a/compiler/utils/Outputable.lhs +++ b/compiler/utils/Outputable.lhs @@ -16,7 +16,7 @@ module Outputable ( PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, unqualStyle, + ifPprDebug, qualName, qualModule, mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle, SDoc, -- Abstract @@ -51,7 +51,8 @@ module Outputable ( #include "HsVersions.h" -import {-# SOURCE #-} Module( Module ) +import {-# SOURCE #-} Module( Module, modulePackageId, + ModuleName, moduleName ) import {-# SOURCE #-} OccName( OccName ) import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength ) @@ -99,33 +100,64 @@ data Depth = AllTheWay | PartWay Int -- 0 => stop -type PrintUnqualified = Module -> OccName -> Bool - -- This function tells when it's ok to print - -- a (Global) name unqualified +-- ----------------------------------------------------------------------------- +-- Printing original names -alwaysQualify,neverQualify :: PrintUnqualified -alwaysQualify m n = False -neverQualify m n = True +-- When printing code that contains original names, we need to map the +-- original names back to something the user understands. This is the +-- purpose of the pair of functions that gets passed around +-- when rendering 'SDoc'. + +-- | given an /original/ name, this function tells you which module +-- name it should be qualified with when printing for the user, if +-- any. For example, given @Control.Exception.catch@, which is in scope +-- as @Exception.catch@, this fuction will return @Just "Exception"@. +-- Note that the return value is a ModuleName, not a Module, because +-- in source code, names are qualified by ModuleNames. +type QualifyName = Module -> OccName -> Maybe ModuleName + +-- | For a given module, we need to know whether to print it with +-- a package name to disambiguate it, and if so which package name should +-- we use. +type QualifyModule = Module -> Maybe PackageId + +type PrintUnqualified = (QualifyName, QualifyModule) + +alwaysQualifyNames :: QualifyName +alwaysQualifyNames m n = Just (moduleName m) + +neverQualifyNames :: QualifyName +neverQualifyNames m n = Nothing + +alwaysQualifyModules :: QualifyModule +alwaysQualifyModules m = Just (modulePackageId m) + +neverQualifyModules :: QualifyModule +neverQualifyModules m = Nothing + +alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules) +neverQualify = (neverQualifyNames, neverQualifyModules) defaultUserStyle = mkUserStyle alwaysQualify AllTheWay defaultDumpStyle | opt_PprStyle_Debug = PprDebug | otherwise = PprDump +-- | Style for printing error messages mkErrStyle :: PrintUnqualified -> PprStyle --- Style for printing error messages -mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength) +mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength) defaultErrStyle :: PprStyle -- Default style for error messages -- It's a bit of a hack because it doesn't take into account what's in scope -- Only used for desugarer warnings, and typechecker errors in interface sigs defaultErrStyle - | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay - | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength) + | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay + | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength) -mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug - | otherwise = PprUser unqual depth +mkUserStyle unqual depth + | opt_PprStyle_Debug = PprDebug + | otherwise = PprUser unqual depth \end{code} Orthogonal to the above printing styles are (possibly) some @@ -152,22 +184,26 @@ withPprStyleDoc :: PprStyle -> SDoc -> Doc withPprStyleDoc sty d = d sty pprDeeper :: SDoc -> SDoc -pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..." -pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1))) -pprDeeper d other_sty = d other_sty +pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..." +pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1))) +pprDeeper d other_sty = d other_sty pprSetDepth :: Int -> SDoc -> SDoc -pprSetDepth n d (PprUser unqual _) = d (PprUser unqual (PartWay n)) -pprSetDepth n d other_sty = d other_sty +pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n)) +pprSetDepth n d other_sty = d other_sty getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df sty = df sty sty \end{code} \begin{code} -unqualStyle :: PprStyle -> PrintUnqualified -unqualStyle (PprUser unqual _) m n = unqual m n -unqualStyle other m n = False +qualName :: PprStyle -> QualifyName +qualName (PprUser (qual_name,_) _) m n = qual_name m n +qualName other m n = Just (moduleName m) + +qualModule :: PprStyle -> QualifyModule +qualModule (PprUser (_,qual_mod) _) m = qual_mod m +qualModule other m = Just (modulePackageId m) codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True