diff options
71 files changed, 1899 insertions, 1645 deletions
diff --git a/compiler/Makefile b/compiler/Makefile index 56673df423..4aa67ce75e 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 0000000000..626ec511a0 --- /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 0c84685f87..172f8b001a 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 f9b00f151a..720c51f163 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 d75c032d45..37fa6a9938 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 1e1fb31f84..3684a70306 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 7965449110..3c6cd77c53 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 5c8328116a..aacac3e0dd 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 5908314c87..a1cbbf51ed 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 f78edda655..96735ef211 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 e7c08940c5..7b4861a11d 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 0d8d731029..115439a0fd 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 33d72f1608..e36b2ae236 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 10f41bdf8b..e66e1b8ead 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 184af904df..ae6c892b5d 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 22462e79e5..1866df4cef 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 eee1083fca..9bbf05b90c 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 dd7327b745..56614a87f3 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 2f69927db0..21e6d0850c 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 84d9dd95ef..d137d4d3ca 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 48c0cbfbb9..0422a875e1 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 e737348885..c8c922e725 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 3910d5b265..1d2ee0e396 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 45dc113cc1..7b3847ecde 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 e5cbbfbe51..46fc0747a2 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 88b0ba9c8e..c1f2456830 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 f24dee4905..ae76bfdfec 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 875f1d6331..d294178e5d 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 55384bc63e..8a20fb1b99 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 = "<interactive>", 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 cec1047be8..26f40ebbe4 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 77e9e08224..88d8954bf1 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 220afb7499..f63d86aec2 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 a9982a630a..0efa1e32c8 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 631a28660e..6af109c6f0 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 c7e78b3d45..3eceaa0f04 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 bf0f3831b4..a487489f3a 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 8c496f76ef..8bcf987c99 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 }, - "<built in interface for GHC.Prim>")) + ; if mod == gHC_PRIM + then returnM (Succeeded (ghcPrimIface, + "<built in interface for GHC.Prim>")) 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 3ff30d971a..b86aa92493 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 0b4df3336e..bd31cc04db 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 d1b293353a..30f273ebaa 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 80d906c4a7..56f57f0f71 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 a39ca38a99..800baf1480 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 731ac29b49..bc6a0af300 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 fbde40f6ea..fd0982da19 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 5f82cf3fdb..543d2a940d 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 913ac33a33..847d193c28 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 182391034c..e5b7026eb5 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 e67de3bd36..a200bf99ca 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 e19a10dbc5..bfd2f34496 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 ae6b18863e..22494111fb 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 370e5326d0..c0d19df90a 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 45405088fc..a9cc53f5fe 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 a750397ea3..da16bff272 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 02a6c7b91d..a9669b23ec 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 ae544b30ce..5d61075ecd 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 ceb4df550a..8a5c3bacfb 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 3ee46a88db..56fde05608 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 c95db9c358..8e02892254 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 2be3bfd5c0..1c5a559ee8 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 87af074190..e968590812 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 658028c3f3..71d5c9b350 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 e87877cb4c..a7b2239cf1 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 824cabaacb..50b2973ed5 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 f1c50cc8fd..74832a24aa 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 8768e20250..77ca56a10e 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 d8058d56a9..be1ce9b964 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 fc38fd541a..7adb9d5eb5 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 ee3c6c6bf0..f515334830 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 4ad1b0de83..3c3ca95b03 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 7c3aa8637a..cce4becd89 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 cf99e12bcf..52262ec02e 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 |