#
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
# -----------------------------------------------------------------------------
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
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
# ----------------------------------------------------------------------------
# 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
#-----------------------------------------------------------------------------
--- /dev/null
+# 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)
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}
\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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
%************************************************************************
\begin{code}
-type ModuleEnv elt = UniqFM elt
+type ModuleEnv elt = FiniteMap Module elt
emptyModuleEnv :: ModuleEnv a
mkModuleEnv :: [(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
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}
\begin{code}
module Module where
+import PackageConfig (PackageId)
+
data Module
+data ModuleName
+moduleName :: Module -> ModuleName
+modulePackageId :: Module -> PackageId
\end{code}
-
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 )
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
}
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
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
-- 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}
%************************************************************************
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
#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 )
= 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;
%************************************************************************
\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
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
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)
isQual (Qual _ _) = True
isQual _ = False
+isQual_maybe (Qual m n) = Just (m,n)
+isQual_maybe _ = Nothing
+
isOrig (Orig _ _) = True
isOrig _ = False
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
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
}
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]
#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 )
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
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
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
import UniqFM
import SrcLoc
import DynFlags ( DynFlags, DynFlag(..) )
-import Packages ( HomeModules )
import StaticFlags ( opt_SccProfilingOn )
import ErrUtils ( printError, dumpIfSet_dyn, showPass )
import StringBuffer ( hGetStringBuffer )
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
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
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
-- 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-}
-> 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 ()
; 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
\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}
\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) }
\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
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
-- 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
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
| 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
; 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:
\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
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
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
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}
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 )
import CostCentre ( CostCentreStack )
import Util ( mapAccumL, filterOut )
import Constants ( wORD_SIZE )
-import Packages ( HomeModules )
+import PackageConfig ( PackageId )
import Outputable
\end{code}
\begin{code}
layOutDynConstr, layOutStaticConstr
- :: HomeModules
+ :: PackageId
-> DataCon
-> [(CgRep,a)]
-> (ClosureInfo,
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
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,
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
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
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",
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
}
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
-> 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,
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
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 )
--
-------------------------------------------------------------------------
-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)
-------------------------------------------------------------------------
--
-- 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
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 )
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}
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]
| 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)
-- 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
| 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
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 )
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
-> [(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"
-- 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])
\begin{code}
mkModuleInit
:: DynFlags
- -> HomeModules
-> String -- the "way"
-> CollectedCCs -- cost centre info
-> Module
-> 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
(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) [])
-- 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
-- Now do local stuff
; initCostCentres cost_centre_info
- ; mapCs (registerModuleImport hmods way)
+ ; mapCs (registerModuleImport this_pkg way)
(imported_mods++extra_imported_mods)
}
, 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}
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
import VarSet ( unionVarSet )
import VarEnv
import Name ( hashName )
-import Packages ( HomeModules )
#if mingw32_TARGET_OS
import Packages ( isDllName )
#endif
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 )
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.
-- 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
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)
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)
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
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 )
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,
; 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
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,
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,
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,
-> 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 ->
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
-- 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,
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
import FastString ( unpackFS )
import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..) )
+import Maybe ( catMaybes )
import Monad ( zipWithM )
import List ( sortBy )
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
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) }
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)
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 )
; 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
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(..) )
-- 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
-- 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 )
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 )
import Data.Char
import Control.Monad as Monad
import Foreign.StablePtr ( newStablePtr )
-import Text.Printf
import GHC.Exts ( unsafeCoerce# )
import GHC.IOBase ( IOErrorType(InvalidArgument) )
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
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
args = [],
prompt = "%s> ",
session = session,
- options = [] }
+ options = [],
+ prelude = prel_mod }
#ifdef USE_READLINE
Readline.resetTerminal Nothing
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
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
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)
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)
(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
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)))
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,
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"))
-- 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)
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'
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
| 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
args :: [String],
prompt :: String,
session :: GHC.Session,
- options :: [GHCiOption]
+ options :: [GHCiOption],
+ prelude :: Module
}
data GHCiOption
-- 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"
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 )
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(..) )
--
-- 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}
}}
where
hpt = hsc_HPT hsc_env
- dflags = hsc_dflags hsc_env
free_names = nameSetToList (bcoFreeNames root_ul_bco)
needed_mods :: [Module]
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
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
-- 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
}}
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 )
-- 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)
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)
#include "HsVersions.h"
-import Module ( Module )
+import Module ( ModuleName )
import Outputable
import FastString
import SrcLoc ( Located(..) )
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}
| 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}
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*
import IfaceSyn
import VarEnv
import InstEnv ( OverlapFlag(..) )
-import Packages ( PackageIdH(..) )
import Class ( DefMeth(..) )
import CostCentre
import StaticFlags ( opt_HiVersion, v_Build_tag )
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,
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,
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 )
\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
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
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
IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr,
IfaceExtName(..), mkIfaceExtName, isLocalIfaceExtName,
- ifaceTyConName, interactiveExtNameFun,
+ ifaceTyConName,
-- Conversion from Type -> IfaceType
toIfaceType, toIfacePred, toIfaceContext,
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
\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
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}
-- 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
\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,
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 )
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(..) )
%************************************************************************
\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 ()
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
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
%*********************************************************
\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
; 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
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
} -- 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 }
-- 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 ->
-- 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)
%*********************************************************
\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))
-- 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
initExternalPackageState :: ExternalPackageState
initExternalPackageState
= EPS {
- eps_is_boot = emptyModuleEnv,
+ eps_is_boot = emptyUFM,
eps_PIT = emptyPackageIfaceTable,
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
\begin{code}
ghcPrimIface :: ModIface
ghcPrimIface
- = (emptyModIface HomePackage gHC_PRIM) {
+ = (emptyModIface gHC_PRIM) {
mi_exports = [(gHC_PRIM, ghcPrimExports)],
mi_decls = [],
mi_fixities = fixities,
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
#include "HsVersions.h"
import HsSyn
-import Packages ( isHomeModule, PackageIdH(..) )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceRule(..), IfaceInst(..), IfaceExtName(..),
eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool,
)
-import Packages ( HomeModules )
import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_HiVersion )
import Name ( Name, nameModule, nameOccName, nameParent,
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 )
import ErrUtils ( dumpIfSet_dyn, showPass )
import Digraph ( stronglyConnComp, SCC(..) )
import SrcLoc ( SrcSpan )
+import UniqFM
+import PackageConfig ( PackageId )
import FiniteMap
import FastString
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 })
-- 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
; intermediate_iface = ModIface {
mi_module = this_mod,
- mi_package = HomePackage,
mi_boot = is_boot,
mi_deps = deps,
mi_usages = usages,
-----------------------------
-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
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
= 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)
\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
-- (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
-- 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)
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")))
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 ->
; 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}
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
-- 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
-- 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)
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
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 )
-- 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 }
-- 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
-- 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
import PprC ( writeCs )
import CmmLint ( cmmLint )
import Packages
+import PackageConfig ( rtsPackageId )
import Util
import FastString ( unpackFS )
import Cmm ( Cmm )
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 )
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}
"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
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"
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
-----------------------------------------------------------------
processDeps :: Session
- -> [Module]
+ -> [ModuleName]
-> Handle -- Write dependencies to here
-> SCC ModSummary
-> IO ()
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"
}
-- 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);
, ( "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) )
]
import HscTypes
import Outputable
import Module
+import UniqFM ( eltsUFM )
import ErrUtils
import DynFlags
import StaticFlags ( v_Ld_inputs, opt_Static, WayName(..) )
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-}
| 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
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]
-- ---------------------------------------------------------------------------
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
= 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
-- 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)
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
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
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 []
#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
importPaths :: [FilePath],
mainModIs :: Module,
mainFunIs :: Maybe String,
+ thisPackage :: PackageId,
-- ways
wayNames :: [WayName], -- way flags from the cmd line
importPaths = ["."],
mainModIs = mAIN,
mainFunIs = Nothing,
+ thisPackage = mainPackageId,
wayNames = panic "ways",
buildTag = panic "buildTag",
------- 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) )
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).
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 }
%
-% (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 )
-- 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)
-- 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
| 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
-- -----------------------------------------------------------------------------
:: [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
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,
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
-- 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
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,
mkStubPaths
:: DynFlags
- -> Module
+ -> ModuleName
-> ModLocation
-> (FilePath,FilePath)
= 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))
-- -----------------------------------------------------------------------------
-- 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:"),
-> 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.")
-> 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}
TypecheckedSource, ParsedSource, RenamedSource,
-- * Inspecting the module structure of the program
- ModuleGraph, ModSummary(..), ModLocation(..),
+ ModuleGraph, ModSummary(..), ms_mod_name, ModLocation(..),
getModuleGraph,
isLoaded,
topSortModuleGraph,
-- * Interactive evaluation
getBindings, getPrintUnqual,
+ findModule,
#ifdef GHCI
setContext, getContext,
getNamesInScope,
-- * Abstract syntax elements
+ -- ** Packages
+ PackageId,
+
-- ** Modules
- Module, mkModule, pprModule,
+ Module, mkModule, pprModule, moduleName, modulePackageId,
+ ModuleName, mkModuleName, moduleNameString,
-- ** Names
Name,
ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
mkGlobalRdrEnv )
import HscMain ( hscParseIdentifier, hscStmt, hscTcExpr, hscKcType )
+import Name ( nameOccName )
import Type ( tidyType )
import VarEnv ( emptyTidyEnv )
import GHC.Exts ( unsafeCoerce# )
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 )
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 )
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"
-- 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
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,
-- 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 ()
-- 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
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
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
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)
= 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
-- 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
-- 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)
-- 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
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
| 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))
&& 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
-- 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)
-- -----------------------------------------------------------------------------
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
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,
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
-- 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
-- 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
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
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
-- 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
-- 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 ]
-- ---------------------------------------------------------------------------
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
| 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
-- 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
-- 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]
nodeMapElts :: NodeMap a -> [a]
nodeMapElts = eltsFM
+ms_mod_name :: ModSummary -> ModuleName
+ms_mod_name = moduleName . ms_mod
+
-----------------------------------------------------------------------------
-- Downsweep (dependency analysis)
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
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
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
(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
:: 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
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
-- 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
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
-- 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,
-- 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
-- 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
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)
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
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
#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
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
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
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
-- -----------------------------------------------------------------------------
-- 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.
-> [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 }}
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
-- 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]))
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
, 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 )
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
-- 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
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
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
import TyCon ( isDataTyCon )
-import Packages ( mkHomeModules )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import ParserCore
import ParserCoreUtils
import FastString
-import Maybes ( expectJust )
+import UniqFM ( emptyUFM )
import Bag ( unitBag )
import Monad ( unless )
import IO
= 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 = [],
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 } ) }
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
----------------- 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 -----------------------
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
}}
-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}
module HscTypes (
-- * Sessions and compilation state
Session(..), HscEnv(..), hscEPS,
- FinderCache, FinderCacheEntry,
+ FinderCache, FindResult(..), ModLocationCache,
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
ExternalPackageState(..), EpsStats(..), addEpsInStats,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
- lookupIface, lookupIfaceByModule, emptyModIface,
+ lookupIfaceByModule, emptyModIface,
InteractiveContext(..), emptyInteractiveContext,
- icPrintUnqual, unQualInScope,
+ icPrintUnqual, mkPrintUnqualified,
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
emptyIfaceDepCache,
#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
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,
import Maybes ( orElse, expectJust )
import Outputable
import SrcLoc ( SrcSpan, Located )
+import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import FastString ( FastString )
-- 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
}
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.
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
-- 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
-- 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
, 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}
%************************************************************************
%* *
\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
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
-- 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
}
\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,
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}
\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}
-- 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 )
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
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
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.
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}
-- * 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"
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
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")
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,
import Name ( Name, nameModule_maybe )
import UniqFM
import Module
-import FiniteMap
import UniqSet
import Util
import Maybes ( expectJust, MaybeErr(..) )
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
-- 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.
--
-- 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
-- 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
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)
-- 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
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
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
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).
--
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
--
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))
-- | 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
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
-- -----------------------------------------------------------------------------
#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 )
)
import Maybes ( orElse, mapCatMaybes )
import ErrUtils ( showPass, dumpIfSet_core )
+import PackageConfig ( PackageId )
import UniqSupply ( splitUniqSupply, uniqFromSupply )
import List ( partition )
import Maybe ( isJust )
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
-- (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
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,
-- * 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
-> [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
-- 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
-> 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
-- 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
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
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,
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)
-- 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,
}
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)
-> 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
: 'qualified' { True }
| {- empty -} { False }
-maybeas :: { Located (Maybe Module) }
+maybeas :: { Located (Maybe ModuleName) }
: 'as' modid { LL (Just (unLoc $2)) }
| {- empty -} { noLoc Nothing }
-----------------------------------------------------------------------------
-- 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))
}
import Kind( Kind(..) )
import Name( nameOccName, nameModule )
import Module
+import PackageConfig ( mainPackageId )
import ParserCoreUtils
import LexCore
import Literal
: '%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
#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 )
--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}
%************************************************************************
\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}
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
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
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
unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name
newStablePtr_RDR = nameRdrName newStablePtrName
-wordDataCon_RDR = dataQual_RDR pREL_WORD FSLIT("W#")
+wordDataCon_RDR = dataQual_RDR gHC_WORD FSLIT("W#")
bindIO_RDR = nameRdrName bindIOName
returnIO_RDR = nameRdrName returnIOName
fromInteger_RDR = nameRdrName fromIntegerName
fromRational_RDR = nameRdrName fromRationalName
minus_RDR = nameRdrName minusName
-times_RDR = varQual_RDR pREL_NUM FSLIT("*")
-plus_RDR = varQual_RDR pREL_NUM FSLIT("+")
-
-compose_RDR = varQual_RDR pREL_BASE FSLIT(".")
-
-not_RDR = varQual_RDR pREL_BASE FSLIT("not")
-getTag_RDR = varQual_RDR pREL_BASE FSLIT("getTag")
-succ_RDR = varQual_RDR pREL_ENUM FSLIT("succ")
-pred_RDR = varQual_RDR pREL_ENUM FSLIT("pred")
-minBound_RDR = varQual_RDR pREL_ENUM FSLIT("minBound")
-maxBound_RDR = varQual_RDR pREL_ENUM FSLIT("maxBound")
-range_RDR = varQual_RDR pREL_ARR FSLIT("range")
-inRange_RDR = varQual_RDR pREL_ARR FSLIT("inRange")
-index_RDR = varQual_RDR pREL_ARR FSLIT("index")
-unsafeIndex_RDR = varQual_RDR pREL_ARR FSLIT("unsafeIndex")
-unsafeRangeSize_RDR = varQual_RDR pREL_ARR FSLIT("unsafeRangeSize")
-
-readList_RDR = varQual_RDR pREL_READ FSLIT("readList")
-readListDefault_RDR = varQual_RDR pREL_READ FSLIT("readListDefault")
-readListPrec_RDR = varQual_RDR pREL_READ FSLIT("readListPrec")
-readListPrecDefault_RDR = varQual_RDR pREL_READ FSLIT("readListPrecDefault")
-readPrec_RDR = varQual_RDR pREL_READ FSLIT("readPrec")
-parens_RDR = varQual_RDR pREL_READ FSLIT("parens")
-choose_RDR = varQual_RDR pREL_READ FSLIT("choose")
-lexP_RDR = varQual_RDR pREL_READ FSLIT("lexP")
+times_RDR = varQual_RDR gHC_NUM FSLIT("*")
+plus_RDR = varQual_RDR gHC_NUM FSLIT("+")
+
+compose_RDR = varQual_RDR gHC_BASE FSLIT(".")
+
+not_RDR = varQual_RDR gHC_BASE FSLIT("not")
+getTag_RDR = varQual_RDR gHC_BASE FSLIT("getTag")
+succ_RDR = varQual_RDR gHC_ENUM FSLIT("succ")
+pred_RDR = varQual_RDR gHC_ENUM FSLIT("pred")
+minBound_RDR = varQual_RDR gHC_ENUM FSLIT("minBound")
+maxBound_RDR = varQual_RDR gHC_ENUM FSLIT("maxBound")
+range_RDR = varQual_RDR gHC_ARR FSLIT("range")
+inRange_RDR = varQual_RDR gHC_ARR FSLIT("inRange")
+index_RDR = varQual_RDR gHC_ARR FSLIT("index")
+unsafeIndex_RDR = varQual_RDR gHC_ARR FSLIT("unsafeIndex")
+unsafeRangeSize_RDR = varQual_RDR gHC_ARR FSLIT("unsafeRangeSize")
+
+readList_RDR = varQual_RDR gHC_READ FSLIT("readList")
+readListDefault_RDR = varQual_RDR gHC_READ FSLIT("readListDefault")
+readListPrec_RDR = varQual_RDR gHC_READ FSLIT("readListPrec")
+readListPrecDefault_RDR = varQual_RDR gHC_READ FSLIT("readListPrecDefault")
+readPrec_RDR = varQual_RDR gHC_READ FSLIT("readPrec")
+parens_RDR = varQual_RDR gHC_READ FSLIT("parens")
+choose_RDR = varQual_RDR gHC_READ FSLIT("choose")
+lexP_RDR = varQual_RDR gHC_READ FSLIT("lexP")
punc_RDR = dataQual_RDR lEX FSLIT("Punc")
ident_RDR = dataQual_RDR lEX FSLIT("Ident")
reset_RDR = varQual_RDR rEAD_PREC FSLIT("reset")
prec_RDR = varQual_RDR rEAD_PREC FSLIT("prec")
-showList_RDR = varQual_RDR pREL_SHOW FSLIT("showList")
-showList___RDR = varQual_RDR pREL_SHOW FSLIT("showList__")
-showsPrec_RDR = varQual_RDR pREL_SHOW FSLIT("showsPrec")
-showString_RDR = varQual_RDR pREL_SHOW FSLIT("showString")
-showSpace_RDR = varQual_RDR pREL_SHOW FSLIT("showSpace")
-showParen_RDR = varQual_RDR pREL_SHOW FSLIT("showParen")
+showList_RDR = varQual_RDR gHC_SHOW FSLIT("showList")
+showList___RDR = varQual_RDR gHC_SHOW FSLIT("showList__")
+showsPrec_RDR = varQual_RDR gHC_SHOW FSLIT("showsPrec")
+showString_RDR = varQual_RDR gHC_SHOW FSLIT("showString")
+showSpace_RDR = varQual_RDR gHC_SHOW FSLIT("showSpace")
+showParen_RDR = varQual_RDR gHC_SHOW FSLIT("showParen")
typeOf_RDR = varQual_RDR tYPEABLE FSLIT("typeOf")
mkTypeRep_RDR = varQual_RDR tYPEABLE FSLIT("mkTyConApp")
mkTyConRep_RDR = varQual_RDR tYPEABLE FSLIT("mkTyCon")
-undefined_RDR = varQual_RDR pREL_ERR FSLIT("undefined")
+undefined_RDR = varQual_RDR gHC_ERR FSLIT("undefined")
-crossDataCon_RDR = dataQual_RDR pREL_BASE FSLIT(":*:")
-inlDataCon_RDR = dataQual_RDR pREL_BASE FSLIT("Inl")
-inrDataCon_RDR = dataQual_RDR pREL_BASE FSLIT("Inr")
-genUnitDataCon_RDR = dataQual_RDR pREL_BASE FSLIT("Unit")
+crossDataCon_RDR = dataQual_RDR gHC_BASE FSLIT(":*:")
+inlDataCon_RDR = dataQual_RDR gHC_BASE FSLIT("Inl")
+inrDataCon_RDR = dataQual_RDR gHC_BASE FSLIT("Inr")
+genUnitDataCon_RDR = dataQual_RDR gHC_BASE FSLIT("Unit")
----------------------
varQual_RDR mod str = mkOrig mod (mkOccNameFS varName str)
\begin{code}
-runMainIOName = varQual pREL_TOP_HANDLER FSLIT("runMainIO") runMainKey
+runMainIOName = varQual gHC_TOP_HANDLER FSLIT("runMainIO") runMainKey
-orderingTyConName = tcQual pREL_BASE FSLIT("Ordering") orderingTyConKey
+orderingTyConName = tcQual gHC_BASE FSLIT("Ordering") orderingTyConKey
-eitherTyConName = tcQual pREL_EITHER FSLIT("Either") eitherTyConKey
+eitherTyConName = tcQual dATA_EITHER FSLIT("Either") eitherTyConKey
leftDataConName = conName eitherTyConName FSLIT("Left") leftDataConKey
rightDataConName = conName eitherTyConName FSLIT("Right") rightDataConKey
-- Generics
-crossTyConName = tcQual pREL_BASE FSLIT(":*:") crossTyConKey
-plusTyConName = tcQual pREL_BASE FSLIT(":+:") plusTyConKey
-genUnitTyConName = tcQual pREL_BASE FSLIT("Unit") genUnitTyConKey
+crossTyConName = tcQual gHC_BASE FSLIT(":*:") crossTyConKey
+plusTyConName = tcQual gHC_BASE FSLIT(":+:") plusTyConKey
+genUnitTyConName = tcQual gHC_BASE FSLIT("Unit") genUnitTyConKey
-- Base strings Strings
-unpackCStringName = varQual pREL_BASE FSLIT("unpackCString#") unpackCStringIdKey
-unpackCStringAppendName = varQual pREL_BASE FSLIT("unpackAppendCString#") unpackCStringAppendIdKey
-unpackCStringFoldrName = varQual pREL_BASE FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey
-unpackCStringUtf8Name = varQual pREL_BASE FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey
-eqStringName = varQual pREL_BASE FSLIT("eqString") eqStringIdKey
+unpackCStringName = varQual gHC_BASE FSLIT("unpackCString#") unpackCStringIdKey
+unpackCStringAppendName = varQual gHC_BASE FSLIT("unpackAppendCString#") unpackCStringAppendIdKey
+unpackCStringFoldrName = varQual gHC_BASE FSLIT("unpackFoldrCString#") unpackCStringFoldrIdKey
+unpackCStringUtf8Name = varQual gHC_BASE FSLIT("unpackCStringUtf8#") unpackCStringUtf8IdKey
+eqStringName = varQual gHC_BASE FSLIT("eqString") eqStringIdKey
-- The 'inline' function
-inlineIdName = varQual pREL_BASE FSLIT("inline") inlineIdKey
+inlineIdName = varQual gHC_BASE FSLIT("inline") inlineIdKey
-- Base classes (Eq, Ord, Functor)
-eqClassName = clsQual pREL_BASE FSLIT("Eq") eqClassKey
+eqClassName = clsQual gHC_BASE FSLIT("Eq") eqClassKey
eqName = methName eqClassName FSLIT("==") eqClassOpKey
-ordClassName = clsQual pREL_BASE FSLIT("Ord") ordClassKey
+ordClassName = clsQual gHC_BASE FSLIT("Ord") ordClassKey
geName = methName ordClassName FSLIT(">=") geClassOpKey
-functorClassName = clsQual pREL_BASE FSLIT("Functor") functorClassKey
+functorClassName = clsQual gHC_BASE FSLIT("Functor") functorClassKey
-- Class Monad
-monadClassName = clsQual pREL_BASE FSLIT("Monad") monadClassKey
+monadClassName = clsQual gHC_BASE FSLIT("Monad") monadClassKey
thenMName = methName monadClassName FSLIT(">>") thenMClassOpKey
bindMName = methName monadClassName FSLIT(">>=") bindMClassOpKey
returnMName = methName monadClassName FSLIT("return") returnMClassOpKey
failMName = methName monadClassName FSLIT("fail") failMClassOpKey
-- Random PrelBase functions
-otherwiseIdName = varQual pREL_BASE FSLIT("otherwise") otherwiseIdKey
-foldrName = varQual pREL_BASE FSLIT("foldr") foldrIdKey
-buildName = varQual pREL_BASE FSLIT("build") buildIdKey
-augmentName = varQual pREL_BASE FSLIT("augment") augmentIdKey
-appendName = varQual pREL_BASE FSLIT("++") appendIdKey
-andName = varQual pREL_BASE FSLIT("&&") andIdKey
-orName = varQual pREL_BASE FSLIT("||") orIdKey
-assertName = varQual pREL_BASE FSLIT("assert") assertIdKey
-breakpointName = varQual pREL_BASE FSLIT("breakpoint") breakpointIdKey
-breakpointCondName= varQual pREL_BASE FSLIT("breakpointCond") breakpointCondIdKey
+otherwiseIdName = varQual gHC_BASE FSLIT("otherwise") otherwiseIdKey
+foldrName = varQual gHC_BASE FSLIT("foldr") foldrIdKey
+buildName = varQual gHC_BASE FSLIT("build") buildIdKey
+augmentName = varQual gHC_BASE FSLIT("augment") augmentIdKey
+appendName = varQual gHC_BASE FSLIT("++") appendIdKey
+andName = varQual gHC_BASE FSLIT("&&") andIdKey
+orName = varQual gHC_BASE FSLIT("||") orIdKey
+assertName = varQual gHC_BASE FSLIT("assert") assertIdKey
+breakpointName = varQual gHC_BASE FSLIT("breakpoint") breakpointIdKey
+breakpointCondName= varQual gHC_BASE FSLIT("breakpointCond") breakpointCondIdKey
breakpointJumpName
= mkInternalName
breakpointJumpIdKey
noSrcLoc
-- PrelTup
-fstName = varQual pREL_TUP FSLIT("fst") fstIdKey
-sndName = varQual pREL_TUP FSLIT("snd") sndIdKey
+fstName = varQual dATA_TUP FSLIT("fst") fstIdKey
+sndName = varQual dATA_TUP FSLIT("snd") sndIdKey
-- Module PrelNum
-numClassName = clsQual pREL_NUM FSLIT("Num") numClassKey
+numClassName = clsQual gHC_NUM FSLIT("Num") numClassKey
fromIntegerName = methName numClassName FSLIT("fromInteger") fromIntegerClassOpKey
minusName = methName numClassName FSLIT("-") minusClassOpKey
negateName = methName numClassName FSLIT("negate") negateClassOpKey
-plusIntegerName = varQual pREL_NUM FSLIT("plusInteger") plusIntegerIdKey
-timesIntegerName = varQual pREL_NUM FSLIT("timesInteger") timesIntegerIdKey
-integerTyConName = tcQual pREL_NUM FSLIT("Integer") integerTyConKey
+plusIntegerName = varQual gHC_NUM FSLIT("plusInteger") plusIntegerIdKey
+timesIntegerName = varQual gHC_NUM FSLIT("timesInteger") timesIntegerIdKey
+integerTyConName = tcQual gHC_NUM FSLIT("Integer") integerTyConKey
smallIntegerDataConName = conName integerTyConName FSLIT("S#") smallIntegerDataConKey
largeIntegerDataConName = conName integerTyConName FSLIT("J#") largeIntegerDataConKey
-- PrelReal types and classes
-rationalTyConName = tcQual pREL_REAL FSLIT("Rational") rationalTyConKey
-ratioTyConName = tcQual pREL_REAL FSLIT("Ratio") ratioTyConKey
+rationalTyConName = tcQual gHC_REAL FSLIT("Rational") rationalTyConKey
+ratioTyConName = tcQual gHC_REAL FSLIT("Ratio") ratioTyConKey
ratioDataConName = conName ratioTyConName FSLIT(":%") ratioDataConKey
-realClassName = clsQual pREL_REAL FSLIT("Real") realClassKey
-integralClassName = clsQual pREL_REAL FSLIT("Integral") integralClassKey
-realFracClassName = clsQual pREL_REAL FSLIT("RealFrac") realFracClassKey
-fractionalClassName = clsQual pREL_REAL FSLIT("Fractional") fractionalClassKey
+realClassName = clsQual gHC_REAL FSLIT("Real") realClassKey
+integralClassName = clsQual gHC_REAL FSLIT("Integral") integralClassKey
+realFracClassName = clsQual gHC_REAL FSLIT("RealFrac") realFracClassKey
+fractionalClassName = clsQual gHC_REAL FSLIT("Fractional") fractionalClassKey
fromRationalName = methName fractionalClassName FSLIT("fromRational") fromRationalClassOpKey
-- PrelFloat classes
-floatingClassName = clsQual pREL_FLOAT FSLIT("Floating") floatingClassKey
-realFloatClassName = clsQual pREL_FLOAT FSLIT("RealFloat") realFloatClassKey
+floatingClassName = clsQual gHC_FLOAT FSLIT("Floating") floatingClassKey
+realFloatClassName = clsQual gHC_FLOAT FSLIT("RealFloat") realFloatClassKey
-- Class Ix
-ixClassName = clsQual pREL_ARR FSLIT("Ix") ixClassKey
+ixClassName = clsQual gHC_ARR FSLIT("Ix") ixClassKey
-- Class Typeable
typeableClassName = clsQual tYPEABLE FSLIT("Typeable") typeableClassKey
dataClassName = clsQual gENERICS FSLIT("Data") dataClassKey
-- Error module
-assertErrorName = varQual pREL_ERR FSLIT("assertError") assertErrorIdKey
+assertErrorName = varQual gHC_ERR FSLIT("assertError") assertErrorIdKey
-- Enum module (Enum, Bounded)
-enumClassName = clsQual pREL_ENUM FSLIT("Enum") enumClassKey
+enumClassName = clsQual gHC_ENUM FSLIT("Enum") enumClassKey
enumFromName = methName enumClassName FSLIT("enumFrom") enumFromClassOpKey
enumFromToName = methName enumClassName FSLIT("enumFromTo") enumFromToClassOpKey
enumFromThenName = methName enumClassName FSLIT("enumFromThen") enumFromThenClassOpKey
enumFromThenToName = methName enumClassName FSLIT("enumFromThenTo") enumFromThenToClassOpKey
-boundedClassName = clsQual pREL_ENUM FSLIT("Bounded") boundedClassKey
+boundedClassName = clsQual gHC_ENUM FSLIT("Bounded") boundedClassKey
-- List functions
-concatName = varQual pREL_LIST FSLIT("concat") concatIdKey
-filterName = varQual pREL_LIST FSLIT("filter") filterIdKey
-zipName = varQual pREL_LIST FSLIT("zip") zipIdKey
+concatName = varQual gHC_LIST FSLIT("concat") concatIdKey
+filterName = varQual gHC_LIST FSLIT("filter") filterIdKey
+zipName = varQual gHC_LIST FSLIT("zip") zipIdKey
-- Class Show
-showClassName = clsQual pREL_SHOW FSLIT("Show") showClassKey
+showClassName = clsQual gHC_SHOW FSLIT("Show") showClassKey
-- Class Read
-readClassName = clsQual pREL_READ FSLIT("Read") readClassKey
+readClassName = clsQual gHC_READ FSLIT("Read") readClassKey
-- parallel array types and functions
-enumFromToPName = varQual pREL_PARR FSLIT("enumFromToP") enumFromToPIdKey
-enumFromThenToPName= varQual pREL_PARR FSLIT("enumFromThenToP") enumFromThenToPIdKey
-nullPName = varQual pREL_PARR FSLIT("nullP") nullPIdKey
-lengthPName = varQual pREL_PARR FSLIT("lengthP") lengthPIdKey
-replicatePName = varQual pREL_PARR FSLIT("replicateP") replicatePIdKey
-mapPName = varQual pREL_PARR FSLIT("mapP") mapPIdKey
-filterPName = varQual pREL_PARR FSLIT("filterP") filterPIdKey
-zipPName = varQual pREL_PARR FSLIT("zipP") zipPIdKey
-crossPName = varQual pREL_PARR FSLIT("crossP") crossPIdKey
-indexPName = varQual pREL_PARR FSLIT("!:") indexPIdKey
-toPName = varQual pREL_PARR FSLIT("toP") toPIdKey
-bpermutePName = varQual pREL_PARR FSLIT("bpermuteP") bpermutePIdKey
-bpermuteDftPName = varQual pREL_PARR FSLIT("bpermuteDftP") bpermuteDftPIdKey
-indexOfPName = varQual pREL_PARR FSLIT("indexOfP") indexOfPIdKey
+enumFromToPName = varQual gHC_PARR FSLIT("enumFromToP") enumFromToPIdKey
+enumFromThenToPName= varQual gHC_PARR FSLIT("enumFromThenToP") enumFromThenToPIdKey
+nullPName = varQual gHC_PARR FSLIT("nullP") nullPIdKey
+lengthPName = varQual gHC_PARR FSLIT("lengthP") lengthPIdKey
+replicatePName = varQual gHC_PARR FSLIT("replicateP") replicatePIdKey
+mapPName = varQual gHC_PARR FSLIT("mapP") mapPIdKey
+filterPName = varQual gHC_PARR FSLIT("filterP") filterPIdKey
+zipPName = varQual gHC_PARR FSLIT("zipP") zipPIdKey
+crossPName = varQual gHC_PARR FSLIT("crossP") crossPIdKey
+indexPName = varQual gHC_PARR FSLIT("!:") indexPIdKey
+toPName = varQual gHC_PARR FSLIT("toP") toPIdKey
+bpermutePName = varQual gHC_PARR FSLIT("bpermuteP") bpermutePIdKey
+bpermuteDftPName = varQual gHC_PARR FSLIT("bpermuteDftP") bpermuteDftPIdKey
+indexOfPName = varQual gHC_PARR FSLIT("indexOfP") indexOfPIdKey
-- IOBase things
-ioTyConName = tcQual pREL_IO_BASE FSLIT("IO") ioTyConKey
+ioTyConName = tcQual gHC_IO_BASE FSLIT("IO") ioTyConKey
ioDataConName = conName ioTyConName FSLIT("IO") ioDataConKey
-thenIOName = varQual pREL_IO_BASE FSLIT("thenIO") thenIOIdKey
-bindIOName = varQual pREL_IO_BASE FSLIT("bindIO") bindIOIdKey
-returnIOName = varQual pREL_IO_BASE FSLIT("returnIO") returnIOIdKey
-failIOName = varQual pREL_IO_BASE FSLIT("failIO") failIOIdKey
+thenIOName = varQual gHC_IO_BASE FSLIT("thenIO") thenIOIdKey
+bindIOName = varQual gHC_IO_BASE FSLIT("bindIO") bindIOIdKey
+returnIOName = varQual gHC_IO_BASE FSLIT("returnIO") returnIOIdKey
+failIOName = varQual gHC_IO_BASE FSLIT("failIO") failIOIdKey
-- IO things
printName = varQual sYSTEM_IO FSLIT("print") printIdKey
-- Int, Word, and Addr things
-int8TyConName = tcQual pREL_INT FSLIT("Int8") int8TyConKey
-int16TyConName = tcQual pREL_INT FSLIT("Int16") int16TyConKey
-int32TyConName = tcQual pREL_INT FSLIT("Int32") int32TyConKey
-int64TyConName = tcQual pREL_INT FSLIT("Int64") int64TyConKey
+int8TyConName = tcQual gHC_INT FSLIT("Int8") int8TyConKey
+int16TyConName = tcQual gHC_INT FSLIT("Int16") int16TyConKey
+int32TyConName = tcQual gHC_INT FSLIT("Int32") int32TyConKey
+int64TyConName = tcQual gHC_INT FSLIT("Int64") int64TyConKey
-- Word module
-word8TyConName = tcQual pREL_WORD FSLIT("Word8") word8TyConKey
-word16TyConName = tcQual pREL_WORD FSLIT("Word16") word16TyConKey
-word32TyConName = tcQual pREL_WORD FSLIT("Word32") word32TyConKey
-word64TyConName = tcQual pREL_WORD FSLIT("Word64") word64TyConKey
-wordTyConName = tcQual pREL_WORD FSLIT("Word") wordTyConKey
+word8TyConName = tcQual gHC_WORD FSLIT("Word8") word8TyConKey
+word16TyConName = tcQual gHC_WORD FSLIT("Word16") word16TyConKey
+word32TyConName = tcQual gHC_WORD FSLIT("Word32") word32TyConKey
+word64TyConName = tcQual gHC_WORD FSLIT("Word64") word64TyConKey
+wordTyConName = tcQual gHC_WORD FSLIT("Word") wordTyConKey
wordDataConName = conName wordTyConName FSLIT("W#") wordDataConKey
-- PrelPtr module
-ptrTyConName = tcQual pREL_PTR FSLIT("Ptr") ptrTyConKey
-funPtrTyConName = tcQual pREL_PTR FSLIT("FunPtr") funPtrTyConKey
+ptrTyConName = tcQual gHC_PTR FSLIT("Ptr") ptrTyConKey
+funPtrTyConName = tcQual gHC_PTR FSLIT("FunPtr") funPtrTyConKey
-- Foreign objects and weak pointers
-stablePtrTyConName = tcQual pREL_STABLE FSLIT("StablePtr") stablePtrTyConKey
-newStablePtrName = varQual pREL_STABLE FSLIT("newStablePtr") newStablePtrIdKey
+stablePtrTyConName = tcQual gHC_STABLE FSLIT("StablePtr") stablePtrTyConKey
+newStablePtrName = varQual gHC_STABLE FSLIT("newStablePtr") newStablePtrIdKey
-- PrelST module
-runSTRepName = varQual pREL_ST FSLIT("runSTRep") runSTRepIdKey
+runSTRepName = varQual gHC_ST FSLIT("runSTRep") runSTRepIdKey
-- The "split" Id for splittable implicit parameters
splittableClassName = clsQual gLA_EXTS FSLIT("Splittable") splittableClassKey
(ADataCon datacon) -- Relevant DataCon
built_in
-charTyConName = mkWiredInTyConName UserSyntax pREL_BASE FSLIT("Char") charTyConKey charTyCon
-charDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("C#") charDataConKey charDataCon charTyConName
-intTyConName = mkWiredInTyConName UserSyntax pREL_BASE FSLIT("Int") intTyConKey intTyCon
-intDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("I#") intDataConKey intDataCon intTyConName
+charTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Char") charTyConKey charTyCon
+charDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("C#") charDataConKey charDataCon charTyConName
+intTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Int") intTyConKey intTyCon
+intDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("I#") intDataConKey intDataCon intTyConName
-boolTyConName = mkWiredInTyConName UserSyntax pREL_BASE FSLIT("Bool") boolTyConKey boolTyCon
-falseDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("False") falseDataConKey falseDataCon boolTyConName
-trueDataConName = mkWiredInDataConName UserSyntax pREL_BASE FSLIT("True") trueDataConKey trueDataCon boolTyConName
-listTyConName = mkWiredInTyConName BuiltInSyntax pREL_BASE FSLIT("[]") listTyConKey listTyCon
-nilDataConName = mkWiredInDataConName BuiltInSyntax pREL_BASE FSLIT("[]") nilDataConKey nilDataCon listTyConName
-consDataConName = mkWiredInDataConName BuiltInSyntax pREL_BASE FSLIT(":") consDataConKey consDataCon listTyConName
+boolTyConName = mkWiredInTyConName UserSyntax gHC_BASE FSLIT("Bool") boolTyConKey boolTyCon
+falseDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("False") falseDataConKey falseDataCon boolTyConName
+trueDataConName = mkWiredInDataConName UserSyntax gHC_BASE FSLIT("True") trueDataConKey trueDataCon boolTyConName
+listTyConName = mkWiredInTyConName BuiltInSyntax gHC_BASE FSLIT("[]") listTyConKey listTyCon
+nilDataConName = mkWiredInDataConName BuiltInSyntax gHC_BASE FSLIT("[]") nilDataConKey nilDataCon listTyConName
+consDataConName = mkWiredInDataConName BuiltInSyntax gHC_BASE FSLIT(":") consDataConKey consDataCon listTyConName
-floatTyConName = mkWiredInTyConName UserSyntax pREL_FLOAT FSLIT("Float") floatTyConKey floatTyCon
-floatDataConName = mkWiredInDataConName UserSyntax pREL_FLOAT FSLIT("F#") floatDataConKey floatDataCon floatTyConName
-doubleTyConName = mkWiredInTyConName UserSyntax pREL_FLOAT FSLIT("Double") doubleTyConKey doubleTyCon
-doubleDataConName = mkWiredInDataConName UserSyntax pREL_FLOAT FSLIT("D#") doubleDataConKey doubleDataCon doubleTyConName
+floatTyConName = mkWiredInTyConName UserSyntax gHC_FLOAT FSLIT("Float") floatTyConKey floatTyCon
+floatDataConName = mkWiredInDataConName UserSyntax gHC_FLOAT FSLIT("F#") floatDataConKey floatDataCon floatTyConName
+doubleTyConName = mkWiredInTyConName UserSyntax gHC_FLOAT FSLIT("Double") doubleTyConKey doubleTyCon
+doubleDataConName = mkWiredInDataConName UserSyntax gHC_FLOAT FSLIT("D#") doubleDataConKey doubleDataCon doubleTyConName
-parrTyConName = mkWiredInTyConName BuiltInSyntax pREL_PARR FSLIT("[::]") parrTyConKey parrTyCon
-parrDataConName = mkWiredInDataConName UserSyntax pREL_PARR FSLIT("PArr") parrDataConKey parrDataCon parrTyConName
+parrTyConName = mkWiredInTyConName BuiltInSyntax gHC_PARR FSLIT("[::]") parrTyConKey parrTyCon
+parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR FSLIT("PArr") parrDataConKey parrDataCon parrTyConName
boolTyCon_RDR = nameRdrName boolTyConName
false_RDR = nameRdrName falseDataConName
tyvar = head alphaTyVars
tyvarTys = replicate arity $ mkTyVarTy tyvar
nameStr = mkFastString ("MkPArr" ++ show arity)
- name = mkWiredInName pREL_PARR (mkOccNameFS dataName nameStr) uniq
+ name = mkWiredInName gHC_PARR (mkOccNameFS dataName nameStr) uniq
Nothing (ADataCon data_con) UserSyntax
uniq = mkPArrDataConUnique arity
import Var ( Id )
import Name ( getOccName, occNameFS )
-import Module ( Module, moduleFS )
+import Module ( Module )
import Outputable
import FastTypes
import FastString
-- Printing in an interface file or in Core generally
pprCostCentreCore (AllCafsCC {cc_mod = m})
- = text "__sccC" <+> braces (ppr_mod m)
+ = text "__sccC" <+> braces (ppr m)
pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
cc_is_caf = caf, cc_is_dupd = dup})
= text "__scc" <+> braces (hsep [
ftext (zEncodeFS n),
- ppr_mod m,
+ ppr m,
pp_dup dup,
pp_caf caf
])
pp_caf CafCC = text "__C"
pp_caf other = empty
-ppr_mod m = ftext (zEncodeFS (moduleFS m))
-
-- Printing as a C label
ppCostCentreLbl (NoCostCentre) = text "NONE_cc"
ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
- = ppr_mod m <> ftext (zEncodeFS n) <>
+ = ppr m <> ftext (zEncodeFS n) <>
text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
-- This is the name to go in the user-displayed string,
import StgSyn
-import Packages ( HomeModules )
+import PackageConfig ( PackageId )
import StaticFlags ( opt_AutoSccsOnIndividualCafs )
import CostCentre -- lots of things
import Id ( Id )
import Module ( Module )
-import UniqSupply ( uniqFromSupply, splitUniqSupply, UniqSupply )
+import UniqSupply ( splitUniqSupply, UniqSupply )
+#ifdef PROF_DO_BOXING
+import UniqSupply ( uniqFromSupply )
+#endif
import Unique ( Unique )
import VarSet
import ListSetOps ( removeDups )
\begin{code}
stgMassageForProfiling
- :: HomeModules
+ :: PackageId
-> Module -- module name
-> UniqSupply -- unique supply
-> [StgBinding] -- input
-> (CollectedCCs, [StgBinding])
-stgMassageForProfiling pdeps mod_name us stg_binds
+stgMassageForProfiling this_pkg mod_name us stg_binds
= let
((local_ccs, extern_ccs, cc_stacks),
stg_binds2)
do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
do_top_rhs binder (StgRhsClosure _ bi fv u srt [] (StgSCC cc (StgConApp con args)))
- | not (isSccCountCostCentre cc) && not (isDllConApp pdeps con args)
+ | not (isSccCountCostCentre cc) && not (isDllConApp this_pkg con args)
-- Trivial _scc_ around nothing but static data
-- Eliminate _scc_ ... and turn into StgRhsCon
mapAccumMM f b2 ms `thenMM` \ (b3, rs) ->
returnMM (b3, r:rs)
+#ifdef PROF_DO_BOXING
getUniqueMM :: MassageM Unique
getUniqueMM mod scope_cc us ids ccs = (ccs, uniqFromSupply us)
+#endif
addTopLevelIshId :: Id -> MassageM a -> MassageM a
addTopLevelIshId id scope mod scope_cc us ids ccs
#include "HsVersions.h"
-import LoadIface ( loadHomeInterface, loadSrcInterface )
+import LoadIface ( loadInterfaceForName, loadSrcInterface )
import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName )
import HsSyn ( FixitySig(..), HsExpr(..), SyntaxExpr, SyntaxTable,
LHsTyVarBndr, LHsType,
Fixity, hsLTyVarLocNames, replaceTyVarName )
import RdrHsSyn ( extractHsTyRdrTyVars )
-import RdrName ( RdrName, rdrNameModule, isQual, isUnqual, isOrig,
+import RdrName ( RdrName, isQual, isUnqual, isOrig_maybe,
+ isQual_maybe,
mkRdrUnqual, setRdrNameSpace, rdrNameOcc,
pprGlobalRdrEnv, lookupGRE_RdrName,
isExact_maybe, isSrcRdrName,
import NameSet
import OccName ( tcName, isDataOcc, pprNonVarNameSpace, occNameSpace,
reportIfUnused )
-import Module ( Module )
+import Module ( Module, ModuleName )
import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey )
import UniqSupply
import BasicTypes ( IPName, mapIPName )
returnM name
- | isOrig rdr_name
+ | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
= do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN)
(badOrigBinding rdr_name)
-- When reading External Core we get Orig names as binders,
-- the RdrName, not from the environment. In principle, it'd be fine to
-- have an arbitrary mixture of external core definitions in a single module,
-- (apart from module-initialisation issues, perhaps).
- newGlobalBinder rdr_mod (rdrNameOcc rdr_name) mb_parent
+ newGlobalBinder rdr_mod rdr_occ mb_parent
(srcSpanStart loc) --TODO, should pass the whole span
| otherwise
= newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc)
- where
- rdr_mod = rdrNameModule rdr_name
\end{code}
%*********************************************************
| Just name <- isExact_maybe rdr_name
= returnM name
- | isOrig rdr_name
+ | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-- This deals with the case of derived bindings, where
-- we don't bother to call newTopSrcBinder first
-- We assume there is no "parent" name
= do { loc <- getSrcSpanM
- ; newGlobalBinder (rdrNameModule rdr_name)
- (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) }
+ ; newGlobalBinder rdr_mod rdr_occ Nothing (srcSpanStart loc) }
| otherwise
= do { mb_gre <- lookupGreLocalRn rdr_name
-- This happens in derived code
= returnM n
- | otherwise -- Always Orig, even when reading a .hi-boot file
- = ASSERT( not (isUnqual rdr_name) )
- lookupOrig (rdrNameModule rdr_name) (rdrNameOcc rdr_name)
+ -- Always Orig, even when reading a .hi-boot file
+ | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
+ = lookupOrig rdr_mod rdr_occ
+
+ | otherwise
+ = pprPanic "RnEnv.lookupImportedName" (ppr rdr_name)
unboundName :: RdrName -> RnM Name
unboundName rdr_name
-- try to load the interface if we don't already have it.
lookupQualifiedName :: RdrName -> RnM Name
lookupQualifiedName rdr_name
- = let
- mod = rdrNameModule rdr_name
- occ = rdrNameOcc rdr_name
- in
+ | Just (mod,occ) <- isQual_maybe rdr_name
-- Note: we want to behave as we would for a source file import here,
-- and respect hiddenness of modules/packages, hence loadSrcInterface.
- loadSrcInterface doc mod False `thenM` \ iface ->
+ = loadSrcInterface doc mod False `thenM` \ iface ->
case [ (mod,occ) |
(mod,avails) <- mi_exports iface,
((mod,occ):ns) -> ASSERT (null ns)
lookupOrig mod occ
_ -> unboundName rdr_name
+
+ | otherwise
+ = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name)
where
doc = ptext SLIT("Need to find") <+> ppr rdr_name
\end{code}
else -- It's imported
-- For imported names, we have to get their fixities by doing a
- -- loadHomeInterface, and consulting the Ifaces that comes back
+ -- loadInterfaceForName, and consulting the Ifaces that comes back
-- from that, because the interface file for the Name might not
-- have been loaded yet. Why not? Suppose you import module A,
-- which exports a function 'f', thus;
-- 'f', we need to know its fixity, and it's then, and only
-- then, that we load B.hi. That is what's happening here.
--
- -- loadHomeInterface will find B.hi even if B is a hidden module,
+ -- loadInterfaceForName will find B.hi even if B is a hidden module,
-- and that's what we want.
- loadHomeInterface doc name `thenM` \ iface ->
+ loadInterfaceForName doc name `thenM` \ iface ->
returnM (mi_fix_fn iface (nameOccName name))
where
doc = ptext SLIT("Checking fixity for") <+> ppr name
%************************************************************************
\begin{code}
-warnUnusedModules :: [(Module,SrcSpan)] -> RnM ()
+warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM ()
warnUnusedModules mods
= ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
where
import Name ( Name, nameOccName, nameIsLocalOrFrom )
import NameSet
import RdrName ( RdrName, emptyGlobalRdrEnv, extendLocalRdrEnv, lookupLocalRdrEnv )
-import LoadIface ( loadHomeInterface )
+import LoadIface ( loadInterfaceForName )
import UniqFM ( isNullUFM )
import UniqSet ( emptyUniqSet )
import List ( nub )
rnBracket (VarBr n) = do { name <- lookupOccRn n
; this_mod <- getModule
; checkM (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the
- do { loadHomeInterface msg name -- home interface is loaded, and this is the
+ do { loadInterfaceForName msg name -- home interface is loaded, and this is the
; return () } -- only way that is going to happen
; returnM (VarBr name, unitFV name) }
where
#include "HsVersions.h"
-import DynFlags ( DynFlag(..), GhcMode(..) )
+import DynFlags ( DynFlag(..), GhcMode(..), DynFlags(..) )
import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl,
ForeignDecl(..), HsGroup(..), HsValBinds(..),
Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
import TcRnMonad hiding (LIE)
import FiniteMap
-import PrelNames ( pRELUDE, isUnboundName, main_RDR_Unqual )
-import Module ( Module, moduleString, unitModuleEnv,
- lookupModuleEnv, moduleEnvElts, foldModuleEnv )
+import PrelNames
+import Module
import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName,
nameParent, nameParent_maybe, isExternalName,
isBuiltInSyntax )
extendOccEnv )
import HscTypes ( GenAvailInfo(..), AvailInfo,
HomePackageTable, PackageIfaceTable,
- unQualInScope,
+ mkPrintUnqualified,
Deprecs(..), ModIface(..), Dependencies(..),
- lookupIface, ExternalPackageState(..)
+ lookupIfaceByModule, ExternalPackageState(..)
)
-import Packages ( PackageIdH(..) )
import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace,
GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
emptyGlobalRdrEnv, plusGlobalRdrEnv, globalRdrEnvElts,
Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..),
importSpecLoc, importSpecModule, isLocalGRE, pprNameProvenance )
import Outputable
+import UniqFM
import Maybes ( isNothing, catMaybes, mapCatMaybes, seqMaybe, orElse )
import SrcLoc ( Located(..), mkGeneralSrcSpan,
unLoc, noLoc, srcLocSpan, SrcSpan )
| otherwise = [preludeImportDecl]
explicit_prelude_import
= notNull [ () | L _ (ImportDecl mod _ _ _ _) <- imports,
- unLoc mod == pRELUDE ]
+ unLoc mod == pRELUDE_NAME ]
preludeImportDecl :: LImportDecl RdrName
preludeImportDecl
= L loc $
- ImportDecl (L loc pRELUDE)
+ ImportDecl (L loc pRELUDE_NAME)
False {- Not a boot interface -}
False {- Not qualified -}
Nothing {- No "as" -}
let
-- Compute new transitive dependencies
- orphans | is_orph = ASSERT( not (imp_mod_name `elem` dep_orphs deps) )
- imp_mod_name : dep_orphs deps
+ orphans | is_orph = ASSERT( not (imp_mod `elem` dep_orphs deps) )
+ imp_mod : dep_orphs deps
| otherwise = dep_orphs deps
+ pkg = modulePackageId (mi_module iface)
+
(dependent_mods, dependent_pkgs)
- = case mi_package iface of
- HomePackage ->
+ | pkg == thisPackage dflags =
-- Imported module is from the home package
-- Take its dependent modules and add imp_mod itself
-- Take its dependent packages unchanged
-- check. See LoadIface.loadHiBootInterface
((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps)
- ExtPackage pkg ->
+ | otherwise =
-- Imported module is from another package
-- Dump the dependent modules
-- Add the package imp_mod comes from to the dependent packages
-- module M ( module P ) where ...
-- Then we must export whatever came from P unqualified.
imports = ImportAvails {
- imp_env = unitModuleEnv qual_mod_name avail_env,
+ imp_env = unitUFM qual_mod_name avail_env,
imp_mods = unitModuleEnv imp_mod (imp_mod, import_all, loc),
imp_orphs = orphans,
imp_dep_mods = mkModDeps dependent_mods,
; this_mod = tcg_mod gbl_env
; imports = emptyImportAvails {
- imp_env = unitModuleEnv this_mod $
+ imp_env = unitUFM (moduleName this_mod) $
mkNameSet filtered_names
}
}
\begin{code}
type ExportAccum -- The type of the accumulating parameter of
-- the main worker function in rnExports
- = ([Module], -- 'module M's seen so far
+ = ([ModuleName], -- 'module M's seen so far
ExportOccMap, -- Tracks exported occurrence names
NameSet) -- The accumulated exported stuff
emptyExportAccum = ([], emptyOccEnv, emptyNameSet)
rnExports (Just exports)
= do TcGblEnv { tcg_imports = ImportAvails { imp_env = imp_env } } <- getGblEnv
let sub_env :: NameEnv [Name] -- Classify each name by its parent
- sub_env = mkSubNameEnv (foldModuleEnv unionNameSets emptyNameSet imp_env)
+ sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env)
rnExport (IEVar rdrName)
= do name <- lookupGlobalOccRn rdrName
return (IEVar name)
return exports
where
sub_env :: NameEnv [Name] -- Classify each name by its parent
- sub_env = mkSubNameEnv (foldModuleEnv unionNameSets emptyNameSet imp_env)
+ sub_env = mkSubNameEnv (foldUFM unionNameSets emptyNameSet imp_env)
do_litem :: ExportAccum -> (LIE Name, LIE RdrName) -> RnM ExportAccum
do_litem acc (ieName, ieRdr)
returnM acc }
| otherwise
- = case lookupModuleEnv imp_env mod of
+ = case lookupUFM imp_env mod of
Nothing -> do addErr (modExportErr mod)
return acc
Just names
%*********************************************************
\begin{code}
-reportDeprecations :: TcGblEnv -> RnM ()
-reportDeprecations tcg_env
+reportDeprecations :: DynFlags -> TcGblEnv -> RnM ()
+reportDeprecations dflags tcg_env
= ifOptM Opt_WarnDeprecations $
do { (eps,hpt) <- getEpsAndHpt
-- By this time, typechecking is complete,
check hpt pit (GRE {gre_name = name, gre_prov = Imported (imp_spec:_)})
| name `elemNameSet` used_names
- , Just deprec_txt <- lookupDeprec hpt pit name
+ , Just deprec_txt <- lookupDeprec dflags hpt pit name
= setSrcSpan (importSpecLoc imp_spec) $
addWarn (sep [ptext SLIT("Deprecated use of") <+>
pprNonVarNameSpace (occNameSpace (nameOccName name)) <+>
name_mod = nameModule name
imp_mod = importSpecModule imp_spec
imp_msg = ptext SLIT("imported from") <+> ppr imp_mod <> extra
- extra | imp_mod == name_mod = empty
+ extra | imp_mod == moduleName name_mod = empty
| otherwise = ptext SLIT(", but defined in") <+> ppr name_mod
check hpt pit ok_gre = returnM () -- Local, or not used, or not deprectated
-- the defn of a non-deprecated thing, when changing a module's
-- interface
-lookupDeprec :: HomePackageTable -> PackageIfaceTable
+lookupDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable
-> Name -> Maybe DeprecTxt
-lookupDeprec hpt pit n
- = case lookupIface hpt pit (nameModule n) of
+lookupDeprec dflags hpt pit n
+ = case lookupIfaceByModule dflags hpt pit (nameModule n) of
Just iface -> mi_dep_fn iface n `seqMaybe` -- Bleat if the thing, *or
mi_dep_fn iface (nameParent n) -- its parent*, is deprec'd
Nothing
-- into a bunch of avails, so they are properly grouped
--
-- BUG WARNING: this does not deal properly with qualified imports!
- minimal_imports :: FiniteMap Module AvailEnv
+ minimal_imports :: FiniteMap ModuleName AvailEnv
minimal_imports0 = foldr add_expall emptyFM expall_mods
minimal_imports1 = foldr add_name minimal_imports0 defined_and_used
minimal_imports = foldr add_inst_mod minimal_imports1 direct_import_mods
| otherwise = Avail n
add_inst_mod (mod,_,_) acc
- | mod `elemFM` acc = acc -- We import something already
- | otherwise = addToFM acc mod emptyAvailEnv
+ | mod_name `elemFM` acc = acc -- We import something already
+ | otherwise = addToFM acc mod_name emptyAvailEnv
where
+ mod_name = moduleName mod
-- Add an empty collection of imports for a module
-- from which we have sucked only instance decls
--
-- BUG WARNING: does not deal correctly with multiple imports of the same module
-- becuase direct_import_mods has only one entry per module
- unused_imp_mods = [(mod,loc) | (mod,no_imp,loc) <- direct_import_mods,
- not (mod `elemFM` minimal_imports1),
+ unused_imp_mods = [(mod_name,loc) | (mod,no_imp,loc) <- direct_import_mods,
+ let mod_name = moduleName mod,
+ not (mod_name `elemFM` minimal_imports1),
mod /= pRELUDE,
not no_imp]
-- The not no_imp part is not to complain about
-- import M (), which is an idiom for importing
-- instance declarations
- module_unused :: Module -> Bool
+ module_unused :: ModuleName -> Bool
module_unused mod = any (((==) mod) . fst) unused_imp_mods
---------------------
selectiveImpItem (ImpSome {}) = True
-- ToDo: deal with original imports with 'qualified' and 'as M' clauses
-printMinimalImports :: FiniteMap Module AvailEnv -- Minimal imports
+printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports
-> RnM ()
printMinimalImports imps
= ifOptM Opt_D_dump_minimal_imports $ do {
this_mod <- getModule ;
rdr_env <- getGlobalRdrEnv ;
ioToTcRn (do { h <- openFile (mkFilename this_mod) WriteMode ;
- printForUser h (unQualInScope rdr_env)
+ printForUser h (mkPrintUnqualified rdr_env)
(vcat (map ppr_mod_ie mod_ies)) })
}
where
- mkFilename this_mod = moduleString this_mod ++ ".imports"
+ mkFilename this_mod = moduleNameString (moduleName this_mod) ++ ".imports"
ppr_mod_ie (mod_name, ies)
- | mod_name == pRELUDE
+ | mod_name == moduleName pRELUDE
= empty
| null ies -- Nothing except instances comes from here
= ptext SLIT("import") <+> ppr mod_name <> ptext SLIT("() -- Instances only")
to_ie (AvailTC n ns)
= loadSrcInterface doc n_mod False `thenM` \ iface ->
case [xs | (m,as) <- mi_exports iface,
- m == n_mod,
+ moduleName m == n_mod,
AvailTC x xs <- as,
x == nameOccName n] of
[xs] | all_used xs -> returnM (IEThingAll n)
where
all_used avail_occs = all (`elem` map nameOccName ns) avail_occs
doc = text "Compute minimal imports from" <+> ppr n
- n_mod = nameModule n
+ n_mod = moduleName (nameModule n)
\end{code}
import StgStats ( showStgStats )
import SRT ( computeSRTs )
-import Packages ( HomeModules )
import DynFlags ( DynFlags(..), DynFlag(..), dopt, StgToDo(..),
getStgToDo )
import Id ( Id )
\begin{code}
stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do
- -> HomeModules
-> Module -- module name (profiling only)
-> [StgBinding] -- input...
-> IO ( [(StgBinding,[(Id,[Id])])] -- output program...
, CollectedCCs) -- cost centre information (declared and used)
-stg2stg dflags pkg_deps module_name binds
+stg2stg dflags module_name binds
= do { showPass dflags "Stg2Stg"
; us <- mkSplitUniqSupply 'g'
{-# SCC "ProfMassage" #-}
let
(collected_CCs, binds3)
- = stgMassageForProfiling pkg_deps module_name us1 binds
+ = stgMassageForProfiling this_pkg module_name us1 binds
+ this_pkg = thisPackage dflags
in
end_pass us2 "ProfMassage" collected_CCs binds3
import Name ( getOccName, isExternalName, nameOccName )
import OccName ( occNameString, occNameFS )
import BasicTypes ( Arity )
-import Packages ( HomeModules )
import StaticFlags ( opt_RuntimeTypes )
+import PackageConfig ( PackageId )
import Outputable
infixr 9 `thenLne`
%************************************************************************
\begin{code}
-coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding]
-coreToStg hmods pgm
+coreToStg :: PackageId -> [CoreBind] -> IO [StgBinding]
+coreToStg this_pkg pgm
= return pgm'
- where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm
+ where (_, _, pgm') = coreTopBindsToStg this_pkg emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
coreTopBindsToStg
- :: HomeModules
+ :: PackageId
-> IdEnv HowBound -- environment for the bindings
-> [CoreBind]
-> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
-coreTopBindsToStg hmods env [] = (env, emptyFVInfo, [])
-coreTopBindsToStg hmods env (b:bs)
+coreTopBindsToStg this_pkg env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg this_pkg env (b:bs)
= (env2, fvs2, b':bs')
where
-- env accumulates down the list of binds, fvs accumulates upwards
- (env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b
- (env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs
+ (env1, fvs2, b' ) = coreTopBindToStg this_pkg env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg this_pkg env1 bs
coreTopBindToStg
- :: HomeModules
+ :: PackageId
-> IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
-> (IdEnv HowBound, FreeVarsInfo, StgBinding)
-coreTopBindToStg hmods env body_fvs (NonRec id rhs)
+coreTopBindToStg this_pkg env body_fvs (NonRec id rhs)
= let
env' = extendVarEnv env id how_bound
how_bound = LetBound TopLet $! manifestArity rhs
(stg_rhs, fvs') =
initLne env (
- coreToTopStgRhs hmods body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
+ coreToTopStgRhs this_pkg body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
returnLne (stg_rhs, fvs')
)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
-coreTopBindToStg hmods env body_fvs (Rec pairs)
+coreTopBindToStg this_pkg env body_fvs (Rec pairs)
= let
(binders, rhss) = unzip pairs
(stg_rhss, fvs')
= initLne env' (
- mapAndUnzipLne (coreToTopStgRhs hmods body_fvs) pairs
+ mapAndUnzipLne (coreToTopStgRhs this_pkg body_fvs) pairs
`thenLne` \ (stg_rhss, fvss') ->
let fvs' = unionFVInfos fvss' in
returnLne (stg_rhss, fvs')
\begin{code}
coreToTopStgRhs
- :: HomeModules
+ :: PackageId
-> FreeVarsInfo -- Free var info for the scope of the binding
-> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
-coreToTopStgRhs hmods scope_fv_info (bndr, rhs)
+coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info ->
returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
- is_static = rhsIsStatic hmods rhs
+ is_static = rhsIsStatic this_pkg rhs
mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr
-> StgRhs
import Id ( Id, idName, idType, idCafInfo )
import IdInfo ( mayHaveCafRefs )
import Packages ( isDllName )
+import PackageConfig ( PackageId )
import Literal ( Literal, literalType )
import ForeignCall ( ForeignCall )
import DataCon ( DataCon, dataConName )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
import Unique ( Unique )
import Bitmap
-import DynFlags ( DynFlags )
-import Packages ( HomeModules )
import StaticFlags ( opt_SccProfilingOn )
\end{code}
isStgTypeArg (StgTypeArg _) = True
isStgTypeArg other = False
-isDllArg :: HomeModules -> StgArg -> Bool
+isDllArg :: PackageId -> StgArg -> Bool
-- Does this argument refer to something in a different DLL?
-isDllArg hmods (StgTypeArg v) = False
-isDllArg hmods (StgVarArg v) = isDllName hmods (idName v)
-isDllArg hmods (StgLitArg lit) = False
+isDllArg this_pkg (StgTypeArg v) = False
+isDllArg this_pkg (StgVarArg v) = isDllName this_pkg (idName v)
+isDllArg this_pkg (StgLitArg lit) = False
-isDllConApp :: HomeModules -> DataCon -> [StgArg] -> Bool
+isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool
-- Does this constructor application refer to
-- anything in a different DLL?
-- If so, we can't allocate it statically
-isDllConApp hmods con args
- = isDllName hmods (dataConName con) || any (isDllArg hmods) args
+isDllConApp this_pkg con args
+ = isDllName this_pkg (dataConName con) || any (isDllArg this_pkg) args
stgArgType :: StgArg -> Type
-- Very half baked becase we have lost the type arguments
import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst,
notElemTvSubst, extendTvSubstList )
import Unify ( tcMatchTys )
+import Module ( modulePackageId )
import Kind ( isSubKind )
-import Packages ( isHomeModule )
-import HscTypes ( ExternalPackageState(..) )
+import HscTypes ( ExternalPackageState(..), HscEnv(..) )
import CoreFVs ( idFreeTyVars )
import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName, dataConWrapId )
import Id ( Id, idName, idType, mkUserLocal, mkLocalId )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
-import DynFlags ( DynFlag(..), dopt )
+import DynFlags ( DynFlag(..), DynFlags(..), dopt )
import Maybes ( isJust )
import Outputable
\end{code}
lookupPred ip_pred = return Nothing
record_dfun_usage dfun_id
- = do { gbl <- getGblEnv
+ = do { hsc_env <- getTopEnv
; let dfun_name = idName dfun_id
dfun_mod = nameModule dfun_name
; if isInternalName dfun_name || -- Internal name => defined in this module
- not (isHomeModule (tcg_home_mods gbl) dfun_mod)
+ modulePackageId dfun_mod /= thisPackage (hsc_dflags hsc_env)
then return () -- internal, or in another package
else do { tcg_env <- getGblEnv
; updMutVar (tcg_inst_uses tcg_env)
-- Try global envt
{ (eps,hpt) <- getEpsAndHpt
- ; case lookupType hpt (eps_PTE eps) name of {
+ ; dflags <- getDOpts
+ ; case lookupType dflags hpt (eps_PTE eps) name of {
Just thing -> return thing ;
Nothing -> do
import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
import StaticFlags ( opt_PprStyle_Debug )
-import Packages ( checkForPackageConflicts, mkHomeModules )
import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
SpliceDecl(..), HsBind(..), LHsBinds,
emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds,
import ErrUtils ( Messages, mkDumpDoc, showPass )
import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
import Var ( Var )
-import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv )
+import Module
+import UniqFM ( elemUFM, eltsUFM )
import OccName ( mkVarOccFS, plusOccEnv )
import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName,
mkExternalName )
import Inst ( tcGetInstEnvs )
import InstEnv ( classInstances, instEnvElts )
import RnExpr ( rnStmts, rnLExpr )
-import LoadIface ( loadSrcInterface, loadSysInterface )
+import LoadIface ( loadSysInterface )
import IfaceEnv ( ifaceExportNames )
-import Module ( moduleSetElts, mkModuleSet )
import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
import Id ( setIdType )
import MkId ( unsafeCoerceId )
#endif
import FastString ( mkFastString )
-import Maybes ( MaybeErr(..) )
import Util ( sortLe )
import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
-import Maybe ( isJust )
+import Data.Maybe ( isJust, isNothing )
\end{code}
import_decls local_decls mod_deprec))
= do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
- let { this_mod = case maybe_mod of
- Nothing -> mAIN -- 'module M where' is omitted
- Just (L _ mod) -> mod } ; -- The normal case
+ let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
+ this_mod = case maybe_mod of
+ Nothing -> mAIN -- 'module M where' is omitted
+ Just (L _ mod) -> mkModule this_pkg mod } ;
+ -- The normal case
initTc hsc_env hsc_src this_mod $
setSrcSpan loc $
rn_imports <- rnImports import_decls ;
(rdr_env, imports) <- mkRdrEnvAndImports rn_imports ;
- let { dep_mods :: ModuleEnv (Module, IsBootInterface)
+ let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
; dep_mods = imp_dep_mods imports
-- We want instance declarations from all home-package
-- modules below this one, including boot modules, except
-- ourselves. The 'except ourselves' is so that we don't
-- get the instances from this module's hs-boot file
- ; want_instances :: Module -> Bool
- ; want_instances mod = mod `elemModuleEnv` dep_mods
- && mod /= this_mod
+ ; want_instances :: ModuleName -> Bool
+ ; want_instances mod = mod `elemUFM` dep_mods
+ && mod /= moduleName this_mod
; home_insts = hptInstances hsc_env want_instances
} ;
-- and any other incrementally-performed imports
updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
- checkConflicts imports this_mod $ do {
-
-- Update the gbl env
updGblEnv ( \ gbl ->
gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env,
-- that we don't bleat about re-exporting a deprecated
-- thing (especially via 'module Foo' export item)
-- Only uses in the body of the module are complained about
- reportDeprecations tcg_env ;
+ reportDeprecations (hsc_dflags hsc_env) tcg_env ;
-- Process the export list
rn_exports <- rnExports export_ies ;
-- Dump output and return
tcDump final_env ;
return final_env
- }}}}}
-
-
--- The program is not allowed to contain two modules with the same
--- name, and we check for that here. It could happen if the home package
--- contains a module that is also present in an external package, for example.
-checkConflicts imports this_mod and_then = do
- dflags <- getDOpts
- let
- dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports))
- -- don't forget to include the current module!
-
- mb_dep_pkgs = checkForPackageConflicts
- dflags dep_mods (imp_dep_pkgs imports)
- --
- case mb_dep_pkgs of
- Failed msg ->
- do addErr msg; failM
- Succeeded _ ->
- updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods })
- and_then
+ }}}}
\end{code}
mg_usages = [], -- ToDo: compute usage
mg_dir_imps = [], -- ??
mg_deps = noDependencies, -- ??
- mg_home_mods = mkHomeModules [], -- ?? wrong!!
mg_exports = my_exports,
mg_types = final_type_env,
mg_insts = tcg_insts tcg_env,
tcGetModuleExports :: Module -> TcM NameSet
tcGetModuleExports mod = do
- iface <- load_iface mod
+ let doc = ptext SLIT("context for compiling statements")
+ iface <- initIfaceTcRn $ loadSysInterface doc mod
loadOrphanModules (dep_orphs (mi_deps iface))
-- Load any orphan-module interfaces,
-- so their instances are visible
ifaceExportNames (mi_exports iface)
-load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
- where
- doc = ptext SLIT("context for compiling statements")
-
-
tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
tcRnLookupRdrName hsc_env rdr_name
= initTcPrintErrors hsc_env iNTERACTIVE $
= all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
where
ok name | isBuiltInSyntax name = True
- | isExternalName name = print_unqual (nameModule name) (nameOccName name)
+ | isExternalName name =
+ isNothing $ fst print_unqual (nameModule name)
+ (nameOccName name)
| otherwise = True
loadUnqualIfaces :: InteractiveContext -> TcM ()
, ppr_insts dfun_ids
, vcat (map ppr rules)
, ppr_gen_tycons (typeEnvTyCons type_env)
- , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
+ , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
, ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
pprModGuts :: ModGuts -> SDoc
import IOEnv -- Re-export all
#if defined(GHCI) && defined(BREAKPOINT)
-import TypeRep ( Type(..), liftedTypeKind, TyThing(..) )
+import TypeRep ( Type(..), liftedTypeKind )
import Var ( mkTyVar, mkGlobalId )
import IdInfo ( GlobalIdDetails(..), vanillaIdInfo )
import OccName ( mkOccName, tvName )
import HsSyn ( emptyLHsBinds )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
- TyThing, TypeEnv, emptyTypeEnv, HscSource(..),
- isHsBoot, ModSummary(..),
+ TypeEnv, emptyTypeEnv, HscSource(..), isHsBoot,
ExternalPackageState(..), HomePackageTable,
Deprecs(..), FixityEnv, FixItem,
- lookupType, unQualInScope )
-import Module ( Module, unitModuleEnv )
+ mkPrintUnqualified )
+import Module ( Module, moduleName )
import RdrName ( GlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv )
-import Name ( Name, isInternalName, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
+import Name ( Name, mkInternalName, tidyNameOcc, nameOccName, getSrcLoc )
import Type ( Type )
import TcType ( tcIsTyVarTy, tcGetTyVar )
import NameEnv ( extendNameEnvList, nameEnvElts )
import ErrUtils ( Message, Messages, emptyMessages, errorsFound,
mkWarnMsg, printErrorsAndWarnings,
mkLocMessage, mkLongErrMsg )
-import Packages ( mkHomeModules )
import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
import NameEnv ( emptyNameEnv )
import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet )
import Bag ( emptyBag )
import Outputable
import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply )
+import UniqFM ( unitUFM )
import Unique ( Unique )
import DynFlags ( DynFlags(..), DynFlag(..), dopt, dopt_set, GhcMode )
import StaticFlags ( opt_PprStyle_Debug )
tcg_th_used = th_var,
tcg_exports = emptyNameSet,
tcg_imports = init_imports,
- tcg_home_mods = home_mods,
tcg_dus = emptyDUs,
tcg_rn_imports = Nothing,
tcg_rn_exports = Nothing,
return (msgs, final_res)
}
where
- home_mods = mkHomeModules (map ms_mod (hsc_mod_graph hsc_env))
- -- A guess at the home modules. This will be correct in
- -- --make and GHCi modes, but in one-shot mode we need to
- -- fix it up after we know the real dependencies of the current
- -- module (see tcRnModule).
- -- Setting it here is necessary for the typechecker entry points
- -- other than tcRnModule: tcRnGetInfo, for example. These are
- -- all called via the GHC module, so hsc_mod_graph will contain
- -- something sensible.
-
- init_imports = emptyImportAvails {imp_env = unitModuleEnv mod emptyNameSet}
+ init_imports = emptyImportAvails {imp_env =
+ unitUFM (moduleName mod) emptyNameSet}
-- Initialise tcg_imports with an empty set of bindings for
-- this module, so that if we see 'module M' in the export
-- list, and there are no bindings in M, we don't bleat
(msgs, res) <- initTc env HsSrcFile mod todo
printErrorsAndWarnings (hsc_dflags env) msgs
return res
-
--- mkImpTypeEnv makes the imported symbol table
-mkImpTypeEnv :: ExternalPackageState -> HomePackageTable
- -> Name -> Maybe TyThing
-mkImpTypeEnv pcs hpt = lookup
- where
- pte = eps_PTE pcs
- lookup name | isInternalName name = Nothing
- | otherwise = lookupType hpt pte name
\end{code}
dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv ;
- ioToTcRn (printForUser stderr (unQualInScope rdr_env) doc) }
+ ioToTcRn (printForUser stderr (mkPrintUnqualified rdr_env) doc) }
dumpOptTcRn :: DynFlag -> SDoc -> TcRn ()
dumpOptTcRn flag doc = ifOptM flag (dumpTcRn doc)
= do { traceTc (ptext SLIT("Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ;
errs_var <- getErrsVar ;
rdr_env <- getGlobalRdrEnv ;
- let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
+ let { err = mkLongErrMsg loc (mkPrintUnqualified rdr_env) msg extra } ;
(warns, errs) <- readMutVar errs_var ;
writeMutVar errs_var (warns, errs `snocBag` err) }
addReportAt loc msg
= do { errs_var <- getErrsVar ;
rdr_env <- getGlobalRdrEnv ;
- let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ;
+ let { warn = mkWarnMsg loc (mkPrintUnqualified rdr_env) msg } ;
(warns, errs) <- readMutVar errs_var ;
writeMutVar errs_var (warns `snocBag` warn, errs) }
HscEnv, TypeEnv, TyThing,
GenAvailInfo(..), AvailInfo, HscSource(..),
availName, IsBootInterface, Deprecations )
-import Packages ( PackageId, HomeModules )
+import Packages ( PackageId )
import Type ( Type, pprTyThingCategory )
import TcType ( TcTyVarSet, TcType, TcThetaType, SkolemInfo, TvSubst,
TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo )
import Var ( Id, TyVar )
import VarEnv ( TidyEnv )
import Module
+import UniqFM
import SrcLoc ( SrcSpan, SrcLoc, Located, srcSpanStart )
import VarSet ( IdSet )
import ErrUtils ( Messages, Message )
type TcIdSet = IdSet
type TcDictBinds = DictBinds TcId -- Bag of dictionary bindings
-
-
type TcRnIf a b c = IOEnv (Env a b) c
type IfM lcl a = TcRnIf IfGblEnv lcl a -- Iface stuff
+
type IfG a = IfM () a -- Top level
type IfL a = IfM IfLclEnv a -- Nested
type TcRn a = TcRnIf TcGblEnv TcLclEnv a
env_top :: HscEnv, -- Top-level stuff that never changes
-- Includes all info about imported things
- env_us :: TcRef UniqSupply, -- Unique supply for local varibles
+ env_us :: {-# UNPACK #-} !(IORef UniqSupply),
+ -- Unique supply for local varibles
env_gbl :: gbl, -- Info about things defined at the top level
-- of the module being compiled
-- from where, including things bound
-- in this module
- tcg_home_mods :: HomeModules,
- -- Calculated from ImportAvails, allows us to
- -- call Packages.isHomeModule
-
tcg_dus :: DefUses, -- What is defined in this module and what is used.
-- The latter is used to generate
-- (a) version tracking; no need to recompile if these
\begin{code}
data ImportAvails
= ImportAvails {
- imp_env :: ModuleEnv NameSet,
+ imp_env :: ModuleNameEnv NameSet,
-- All the things imported, classified by
-- the *module qualifier* for its import
-- e.g. import List as Foo
-- need to recompile if the export version changes
-- (b) to specify what child modules to initialise
- imp_dep_mods :: ModuleEnv (Module, IsBootInterface),
+ imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface),
-- Home-package modules needed by the module being compiled
--
-- It doesn't matter whether any of these dependencies
-- Orphan modules below us in the import tree
}
-mkModDeps :: [(Module, IsBootInterface)]
- -> ModuleEnv (Module, IsBootInterface)
-mkModDeps deps = foldl add emptyModuleEnv deps
+mkModDeps :: [(ModuleName, IsBootInterface)]
+ -> ModuleNameEnv (ModuleName, IsBootInterface)
+mkModDeps deps = foldl add emptyUFM deps
where
- add env elt@(m,_) = extendModuleEnv env m elt
+ add env elt@(m,_) = addToUFM env m elt
emptyImportAvails :: ImportAvails
-emptyImportAvails = ImportAvails { imp_env = emptyModuleEnv,
+emptyImportAvails = ImportAvails { imp_env = emptyUFM,
imp_mods = emptyModuleEnv,
- imp_dep_mods = emptyModuleEnv,
+ imp_dep_mods = emptyUFM,
imp_dep_pkgs = [],
imp_orphs = [] }
imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, imp_orphs = orphs1 })
(ImportAvails { imp_env = env2, imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, imp_orphs = orphs2 })
- = ImportAvails { imp_env = plusModuleEnv_C unionNameSets env1 env2,
+ = ImportAvails { imp_env = plusUFM_C unionNameSets env1 env2,
imp_mods = mods1 `plusModuleEnv` mods2,
- imp_dep_mods = plusModuleEnv_C plus_mod_dep dmods1 dmods2,
+ imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_orphs = orphs1 `unionLists` orphs2 }
where
import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails )
import OccName
import Var ( Id, TyVar, idType )
-import Module ( moduleString )
+import Module ( moduleName, moduleNameString, modulePackageId )
import TcRnMonad
import IfaceEnv ( lookupOrig )
import Class ( Class, classExtraBigSig )
import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc )
import Outputable
import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
-
+import PackageConfig ( packageIdString )
import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) )
import Panic ( showException )
import FastString ( LitString )
qReport True msg = addErr (text msg)
qReport False msg = addReport (text msg)
- qCurrentModule = do { m <- getModule; return (moduleString m) }
+ qCurrentModule = do { m <- getModule;
+ return (moduleNameString (moduleName m)) }
+ -- ToDo: is throwing away the package name ok here?
+
qReify v = reify v
-- For qRecover, discard error messages if
; reifyThing thing
}
where
- ppr_ns (TH.Name _ (TH.NameG TH.DataName mod)) = text "data"
- ppr_ns (TH.Name _ (TH.NameG TH.TcClsName mod)) = text "tc"
- ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var"
+ ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
+ ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
+ ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
lookupThName :: TH.Name -> TcM Name
lookupThName th_name@(TH.Name occ flavour)
else do -- It's imported
{ (eps,hpt) <- getEpsAndHpt
- ; case lookupType hpt (eps_PTE eps) name of
+ ; dflags <- getDOpts
+ ; case lookupType dflags hpt (eps_PTE eps) name of
Just thing -> return (AGlobal thing)
Nothing -> do { thing <- tcImportDecl name
; return (AGlobal thing) }
------------------------------
reifyName :: NamedThing n => n -> TH.Name
reifyName thing
- | isExternalName name = mk_varg mod occ_str
+ | isExternalName name = mk_varg pkg_str mod_str occ_str
| otherwise = TH.mkNameU occ_str (getKey (getUnique name))
-- Many of the things we reify have local bindings, and
-- NameL's aren't supposed to appear in binding positions, so
-- have free variables, we may need to generate NameL's for them.
where
name = getName thing
- mod = moduleString (nameModule name)
+ mod = nameModule name
+ pkg_str = packageIdString (modulePackageId mod)
+ mod_str = moduleNameString (moduleName mod)
occ_str = occNameString occ
occ = nameOccName name
mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
- ifPprDebug, unqualStyle,
+ ifPprDebug, qualName, qualModule,
mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
SDoc, -- Abstract
#include "HsVersions.h"
-import {-# SOURCE #-} Module( Module )
+import {-# SOURCE #-} Module( Module, modulePackageId,
+ ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName )
import StaticFlags ( opt_PprStyle_Debug, opt_PprUserLength )
| PartWay Int -- 0 => stop
-type PrintUnqualified = Module -> OccName -> Bool
- -- This function tells when it's ok to print
- -- a (Global) name unqualified
+-- -----------------------------------------------------------------------------
+-- Printing original names
-alwaysQualify,neverQualify :: PrintUnqualified
-alwaysQualify m n = False
-neverQualify m n = True
+-- When printing code that contains original names, we need to map the
+-- original names back to something the user understands. This is the
+-- purpose of the pair of functions that gets passed around
+-- when rendering 'SDoc'.
+
+-- | given an /original/ name, this function tells you which module
+-- name it should be qualified with when printing for the user, if
+-- any. For example, given @Control.Exception.catch@, which is in scope
+-- as @Exception.catch@, this fuction will return @Just "Exception"@.
+-- Note that the return value is a ModuleName, not a Module, because
+-- in source code, names are qualified by ModuleNames.
+type QualifyName = Module -> OccName -> Maybe ModuleName
+
+-- | For a given module, we need to know whether to print it with
+-- a package name to disambiguate it, and if so which package name should
+-- we use.
+type QualifyModule = Module -> Maybe PackageId
+
+type PrintUnqualified = (QualifyName, QualifyModule)
+
+alwaysQualifyNames :: QualifyName
+alwaysQualifyNames m n = Just (moduleName m)
+
+neverQualifyNames :: QualifyName
+neverQualifyNames m n = Nothing
+
+alwaysQualifyModules :: QualifyModule
+alwaysQualifyModules m = Just (modulePackageId m)
+
+neverQualifyModules :: QualifyModule
+neverQualifyModules m = Nothing
+
+alwaysQualify = (alwaysQualifyNames, alwaysQualifyModules)
+neverQualify = (neverQualifyNames, neverQualifyModules)
defaultUserStyle = mkUserStyle alwaysQualify AllTheWay
defaultDumpStyle | opt_PprStyle_Debug = PprDebug
| otherwise = PprDump
+-- | Style for printing error messages
mkErrStyle :: PrintUnqualified -> PprStyle
--- Style for printing error messages
-mkErrStyle print_unqual = mkUserStyle print_unqual (PartWay opt_PprUserLength)
+mkErrStyle qual = mkUserStyle qual (PartWay opt_PprUserLength)
defaultErrStyle :: PprStyle
-- Default style for error messages
-- It's a bit of a hack because it doesn't take into account what's in scope
-- Only used for desugarer warnings, and typechecker errors in interface sigs
defaultErrStyle
- | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
- | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
+ | opt_PprStyle_Debug = mkUserStyle alwaysQualify AllTheWay
+ | otherwise = mkUserStyle alwaysQualify (PartWay opt_PprUserLength)
-mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug
- | otherwise = PprUser unqual depth
+mkUserStyle unqual depth
+ | opt_PprStyle_Debug = PprDebug
+ | otherwise = PprUser unqual depth
\end{code}
Orthogonal to the above printing styles are (possibly) some
withPprStyleDoc sty d = d sty
pprDeeper :: SDoc -> SDoc
-pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..."
-pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1)))
-pprDeeper d other_sty = d other_sty
+pprDeeper d (PprUser q (PartWay 0)) = Pretty.text "..."
+pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
+pprDeeper d other_sty = d other_sty
pprSetDepth :: Int -> SDoc -> SDoc
-pprSetDepth n d (PprUser unqual _) = d (PprUser unqual (PartWay n))
-pprSetDepth n d other_sty = d other_sty
+pprSetDepth n d (PprUser q _) = d (PprUser q (PartWay n))
+pprSetDepth n d other_sty = d other_sty
getPprStyle :: (PprStyle -> SDoc) -> SDoc
getPprStyle df sty = df sty sty
\end{code}
\begin{code}
-unqualStyle :: PprStyle -> PrintUnqualified
-unqualStyle (PprUser unqual _) m n = unqual m n
-unqualStyle other m n = False
+qualName :: PprStyle -> QualifyName
+qualName (PprUser (qual_name,_) _) m n = qual_name m n
+qualName other m n = Just (moduleName m)
+
+qualModule :: PprStyle -> QualifyModule
+qualModule (PprUser (_,qual_mod) _) m = qual_mod m
+qualModule other m = Just (modulePackageId m)
codeStyle :: PprStyle -> Bool
codeStyle (PprCode _) = True
projects / ghc-hetmet.git / commitdiff