Generalise Package Support
authorSimon Marlow <simonmar@microsoft.com>
Tue, 25 Jul 2006 13:01:54 +0000 (13:01 +0000)
committerSimon Marlow <simonmar@microsoft.com>
Tue, 25 Jul 2006 13:01:54 +0000 (13:01 +0000)
This patch pushes through one fundamental change: a module is now
identified by the pair of its package and module name, whereas
previously it was identified by its module name alone.  This means
that now a program can contain multiple modules with the same name, as
long as they belong to different packages.

This is a language change - the Haskell report says nothing about
packages, but it is now necessary to understand packages in order to
understand GHC's module system.  For example, a type T from module M
in package P is different from a type T from module M in package Q.
Previously this wasn't an issue because there could only be a single
module M in the program.

The "module restriction" on combining packages has therefore been
lifted, and a program can contain multiple versions of the same
package.

Note that none of the proposed syntax changes have yet been
implemented, but the architecture is geared towards supporting import
declarations qualified by package name, and that is probably the next
step.

It is now necessary to specify the package name when compiling a
package, using the -package-name flag (which has been un-deprecated).
Fortunately Cabal still uses -package-name.

Certain packages are "wired in".  Currently the wired-in packages are:
base, haskell98, template-haskell and rts, and are always referred to
by these versionless names.  Other packages are referred to with full
package IDs (eg. "network-1.0").  This is because the compiler needs
to refer to entities in the wired-in packages, and we didn't want to
bake the version of these packages into the comiler.  It's conceivable
that someone might want to upgrade the base package independently of
GHC.

Internal changes:

  - There are two module-related types:

        ModuleName      just a FastString, the name of a module
        Module          a pair of a PackageId and ModuleName

    A mapping from ModuleName can be a UniqFM, but a mapping from Module
    must be a FiniteMap (we provide it as ModuleEnv).

  - The "HomeModules" type that was passed around the compiler is now
    gone, replaced in most cases by the current package name which is
    contained in DynFlags.  We can tell whether a Module comes from the
    current package by comparing its package name against the current
    package.

  - While I was here, I changed PrintUnqual to be a little more useful:
    it now returns the ModuleName that the identifier should be qualified
    with according to the current scope, rather than its original
    module.  Also, PrintUnqual tells whether to qualify module names with
    package names (currently unused).

Docs to follow.

71 files changed:
compiler/Makefile
compiler/Makefile.ghcbin [new file with mode: 0644]
compiler/basicTypes/MkId.lhs
compiler/basicTypes/Module.lhs
compiler/basicTypes/Module.lhs-boot
compiler/basicTypes/Name.lhs
compiler/basicTypes/RdrName.lhs
compiler/cmm/CLabel.hs
compiler/cmm/CmmParse.y
compiler/codeGen/CgBindery.lhs
compiler/codeGen/CgCase.lhs
compiler/codeGen/CgCon.lhs
compiler/codeGen/CgExpr.lhs
compiler/codeGen/CgForeignCall.hs
compiler/codeGen/CgHeapery.lhs
compiler/codeGen/CgMonad.lhs
compiler/codeGen/CgProf.hs
compiler/codeGen/CgTailCall.lhs
compiler/codeGen/CgUtils.hs
compiler/codeGen/ClosureInfo.lhs
compiler/codeGen/CodeGen.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/MkExternalCore.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsMeta.hs
compiler/deSugar/DsMonad.lhs
compiler/ghci/ByteCodeLink.lhs
compiler/ghci/InteractiveUI.hs
compiler/ghci/Linker.lhs
compiler/hsSyn/Convert.lhs
compiler/hsSyn/HsImpExp.lhs
compiler/hsSyn/HsSyn.lhs
compiler/iface/BinIface.hs
compiler/iface/IfaceEnv.lhs
compiler/iface/IfaceType.lhs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/CodeOutput.lhs
compiler/main/DriverMkDepend.hs
compiler/main/DriverPipeline.hs
compiler/main/DynFlags.hs
compiler/main/Finder.lhs
compiler/main/GHC.hs
compiler/main/HeaderInfo.hs
compiler/main/HscMain.lhs
compiler/main/HscTypes.lhs
compiler/main/PackageConfig.hs
compiler/main/Packages.lhs
compiler/main/TidyPgm.lhs
compiler/ndpFlatten/FlattenMonad.hs
compiler/parser/Parser.y.pp
compiler/parser/ParserCore.y
compiler/prelude/PrelNames.lhs
compiler/prelude/TysWiredIn.lhs
compiler/profiling/CostCentre.lhs
compiler/profiling/SCCfinal.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnExpr.lhs
compiler/rename/RnNames.lhs
compiler/simplStg/SimplStg.lhs
compiler/stgSyn/CoreToStg.lhs
compiler/stgSyn/StgSyn.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcSplice.lhs
compiler/utils/Outputable.lhs

index 56673df..4aa67ce 100644 (file)
@@ -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 (file)
index 0000000..626ec51
--- /dev/null
@@ -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)
index 0c84685..172f8b0 100644 (file)
@@ -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}
 
index f9b00f1..720c51f 100644 (file)
@@ -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}
index d75c032..37fa6a9 100644 (file)
@@ -1,6 +1,10 @@
 \begin{code}
 module Module where
 
+import PackageConfig (PackageId)
+
 data Module
+data ModuleName
+moduleName :: Module -> ModuleName
+modulePackageId :: Module -> PackageId
 \end{code}
-
index 1e1fb31..3684a70 100644 (file)
@@ -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}
 
 %************************************************************************
index 7965449..3c6cd77 100644 (file)
@@ -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]
index 5c83281..aacac3e 100644 (file)
@@ -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
 
index 5908314..a1cbbf5 100644 (file)
@@ -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
index f78edda..96735ef 100644 (file)
@@ -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
index e7c0894..7b4861a 100644 (file)
@@ -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-}
index 0d8d731..115439a 100644 (file)
@@ -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
index 33d72f1..e36b2ae 100644 (file)
@@ -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}
 
index 10f41bd..e66e1b8 100644 (file)
@@ -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 )
index 184af90..ae6c892 100644 (file)
@@ -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
index 22462e7..1866df4 100644 (file)
@@ -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 
index eee1083..9bbf05b 100644 (file)
@@ -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,
index dd7327b..56614a8 100644 (file)
@@ -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
index 2f69927..21e6d08 100644 (file)
@@ -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 
index 84d9dd9..d137d4d 100644 (file)
@@ -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
index 48c0cbf..0422a87 100644 (file)
@@ -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 
index e737348..c8c922e 100644 (file)
@@ -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)  
index 3910d5b..1d2ee0e 100644 (file)
@@ -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)
index 45dc113..7b3847e 100644 (file)
@@ -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,
index e5cbbfb..46fc074 100644 (file)
@@ -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 ->
index 88b0ba9..c1f2456 100644 (file)
@@ -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) 
index f24dee4..ae76bfd 100644 (file)
@@ -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
index 875f1d6..d294178 100644 (file)
@@ -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
index 55384bc..8a20fb1 100644 (file)
@@ -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"
index cec1047..26f40eb 100644 (file)
@@ -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
              }}
 
index 77e9e08..88d8954 100644 (file)
@@ -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)
index 220afb7..f63d86a 100644 (file)
@@ -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}
index a9982a6..0efa1e3 100644 (file)
@@ -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*
index 631a286..6af109c 100644 (file)
@@ -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,
index c7e78b3..3eceaa0 100644 (file)
@@ -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
index bf0f383..a487489 100644 (file)
@@ -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
index 8c496f7..8bcf987 100644 (file)
@@ -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
index 3ff30d9..b86aa92 100644 (file)
@@ -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
index 0b4df33..bd31cc0 100644 (file)
@@ -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
 
index d1b2933..30f273e 100644 (file)
@@ -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"
index 80d906c..56f57f0 100644 (file)
@@ -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) )
    ]
index a39ca38..800baf1 100644 (file)
@@ -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 []
index 731ac29..bc6a0af 100644 (file)
@@ -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 }
index fbde40f..fd0982d 100644 (file)
@@ -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}
index 5f82cf3..543d2a9 100644 (file)
@@ -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
index 913ac33..847d193 100644 (file)
@@ -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
index 1823910..e5b7026 100644 (file)
@@ -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}
index e67de3b..a200bf9 100644 (file)
@@ -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}
 
 
index e19a10d..bfd2f34 100644 (file)
@@ -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")
 
index ae6b188..2249411 100644 (file)
@@ -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
 
 -- -----------------------------------------------------------------------------
index 370e532..c0d19df 100644 (file)
@@ -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 
index 4540508..a9cc53f 100644 (file)
@@ -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
index a750397..da16bff 100644 (file)
@@ -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))
                                }
index 02a6c7b..a9669b2 100644 (file)
@@ -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
index ae544b3..5d61075 100644 (file)
@@ -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           &