diff options
| author | simonmar <unknown> | 2004-11-26 16:22:13 +0000 |
|---|---|---|
| committer | simonmar <unknown> | 2004-11-26 16:22:13 +0000 |
| commit | ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1 (patch) | |
| tree | ccf398dd86fd64e8034098b39f47e610885d88cd | |
| parent | 1f8b341a88b6b60935b0ce80b59ed6e356b8cfbf (diff) | |
| download | haskell-ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1.tar.gz | |
[project @ 2004-11-26 16:19:45 by simonmar]
Further integration with the new package story. GHC now supports
pretty much everything in the package proposal.
- GHC now works in terms of PackageIds (<pkg>-<version>) rather than
just package names. You can still specify package names without
versions on the command line, as long as the name is unambiguous.
- GHC understands hidden/exposed modules in a package, and will refuse
to import a hidden module. Also, the hidden/eposed status of packages
is taken into account.
- I had to remove the old package syntax from ghc-pkg, backwards
compatibility isn't really practical.
- All the package.conf.in files have been rewritten in the new syntax,
and contain a complete list of modules in the package. I've set all
the versions to 1.0 for now - please check your package(s) and fix the
version number & other info appropriately.
- New options:
-hide-package P sets the expose flag on package P to False
-ignore-package P unregisters P for this compilation
For comparison, -package P sets the expose flag on package P
to True, and also causes P to be linked in eagerly.
-package-name is no longer officially supported. Unofficially, it's
a synonym for -ignore-package, which has more or less the same effect
as -package-name used to.
Note that a package may be hidden and yet still be linked into
the program, by virtue of being a dependency of some other package.
To completely remove a package from the compiler's internal database,
use -ignore-package.
The compiler will complain if any two packages in the
transitive closure of exposed packages contain the same
module.
You *must* use -ignore-package P when compiling modules for
package P, if package P (or an older version of P) is already
registered. The compiler will helpfully complain if you don't.
The fptools build system does this.
- Note: the Cabal library won't work yet. It still thinks GHC uses
the old package config syntax.
Internal changes/cleanups:
- The ModuleName type has gone away. Modules are now just (a
newtype of) FastStrings, and don't contain any package information.
All the package-related knowledge is in DynFlags, which is passed
down to where it is needed.
- DynFlags manipulation has been cleaned up somewhat: there are no
global variables holding DynFlags any more, instead the DynFlags
are passed around properly.
- There are a few less global variables in GHC. Lots more are
scheduled for removal.
- -i is now a dynamic flag, as are all the package-related flags (but
using them in {-# OPTIONS #-} is Officially Not Recommended).
- make -j now appears to work under fptools/libraries/. Probably
wouldn't take much to get it working for a whole build.
77 files changed, 2447 insertions, 2403 deletions
diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 1a61d1fd9c..f7097685fa 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -522,6 +522,7 @@ endif # from mkDependHS. SRC_MKDEPENDHS_OPTS += \ -optdep--exclude-module=Compat.RawSystem \ + -optdep--exclude-module=Compat.Directory \ -optdep--exclude-module=Data.Version \ -optdep--exclude-module=Distribution.Package \ -optdep--exclude-module=Distribution.InstalledPackageInfo \ diff --git a/ghc/compiler/basicTypes/Module.hi-boot-5 b/ghc/compiler/basicTypes/Module.hi-boot-5 index ebde9b7076..cdc5fbf581 100644 --- a/ghc/compiler/basicTypes/Module.hi-boot-5 +++ b/ghc/compiler/basicTypes/Module.hi-boot-5 @@ -1,4 +1,4 @@ __interface Module 1 0 where -__export Module ModuleName ; -1 data ModuleName ; +__export Module Module ; +1 data Module ; diff --git a/ghc/compiler/basicTypes/Module.hi-boot-6 b/ghc/compiler/basicTypes/Module.hi-boot-6 index d26545c44f..7677859749 100644 --- a/ghc/compiler/basicTypes/Module.hi-boot-6 +++ b/ghc/compiler/basicTypes/Module.hi-boot-6 @@ -1,4 +1,4 @@ module Module where -data ModuleName +data Module diff --git a/ghc/compiler/basicTypes/Module.lhs b/ghc/compiler/basicTypes/Module.lhs index ea4de1ed05..8d4888400a 100644 --- a/ghc/compiler/basicTypes/Module.lhs +++ b/ghc/compiler/basicTypes/Module.lhs @@ -1,72 +1,29 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-2002 +% (c) The University of Glasgow, 2004 % -ModuleName +Module ~~~~~~~~~~ Simply the name of a module, represented as a Z-encoded FastString. These are Uniquable, hence we can build FiniteMaps with ModuleNames as the keys. -Module -~~~~~~ - -A ModuleName with some additional information, namely whether the -module resides in the Home package or in a different package. 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. - -The unique of a Module is identical to the unique of a ModuleName, so -it is safe to look up in a Module map using a ModuleName and vice -versa. - -Notes on DLLs -~~~~~~~~~~~~~ -When compiling module A, which imports module B, we need to -know whether B will be in the same DLL as A. - If it's in the same DLL, we refer to B_f_closure - If it isn't, we refer to _imp__B_f_closure -When compiling A, we record in B's Module value whether it's -in a different DLL, by setting the DLL flag. - - - - \begin{code} module Module ( Module, -- Abstract, instance of Eq, Ord, Outputable + , pprModule -- :: ModuleName -> SDoc , ModLocation(..), , showModMsg - , ModuleName - , pprModuleName -- :: ModuleName -> SDoc - , printModulePrefix + , moduleString -- :: ModuleName -> EncodedString + , moduleUserString -- :: ModuleName -> UserString + , moduleFS -- :: ModuleName -> EncodedFS - , moduleName -- :: Module -> ModuleName - , moduleNameString -- :: ModuleName -> EncodedString - , moduleNameUserString -- :: ModuleName -> UserString - , moduleNameFS -- :: ModuleName -> EncodedFS - - , moduleString -- :: Module -> EncodedString - , moduleUserString -- :: Module -> UserString - - , mkModule - , mkBasePkgModule -- :: UserString -> Module - , mkHomeModule -- :: ModuleName -> Module - , isHomeModule -- :: Module -> Bool - , mkPackageModule -- :: ModuleName -> Module - - , mkModuleName -- :: UserString -> ModuleName - , mkModuleNameFS -- :: UserFS -> ModuleName - , mkSysModuleNameFS -- :: EncodedFS -> ModuleName - - , pprModule, + , mkModule -- :: UserString -> ModuleName + , mkModuleFS -- :: UserFS -> ModuleName + , mkSysModuleFS -- :: EncodedFS -> ModuleName , ModuleEnv, , elemModuleEnv, extendModuleEnv, extendModuleEnvList, plusModuleEnv_C @@ -74,7 +31,6 @@ module Module , lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv , moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv , extendModuleEnv_C - , lookupModuleEnvByName, extendModuleEnvByName, unitModuleEnvByName , ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet @@ -83,8 +39,6 @@ module Module #include "HsVersions.h" import OccName import Outputable -import Packages ( PackageName, basePackage ) -import CmdLineOpts ( opt_InPackage ) import Unique ( Uniquable(..) ) import Maybes ( expectJust ) import UniqFM @@ -93,44 +47,6 @@ import Binary import FastString \end{code} - -%************************************************************************ -%* * -\subsection{Interface file flavour} -%* * -%************************************************************************ - -A further twist to the tale is the support for dynamically linked -libraries under Win32. Here, dealing with the use of global variables -that's residing in a DLL requires special handling at the point of use -(there's an extra level of indirection, i.e., (**v) to get at v's -value, rather than just (*v) .) When slurping in an interface file we -then record whether it's coming from a .hi corresponding to a module -that's packaged up in a DLL or not, so that we later can emit the -appropriate code. - -The logic for how an interface file is marked as corresponding to a -module that's hiding in a DLL is explained elsewhere (ToDo: give -renamer href here.) - -\begin{code} -data Module = Module ModuleName !PackageInfo - -data PackageInfo - = ThisPackage -- A module from the same package - -- as the one being compiled - | AnotherPackage -- A module from a different package - -packageInfoPackage :: PackageInfo -> PackageName -packageInfoPackage ThisPackage = opt_InPackage -packageInfoPackage AnotherPackage = FSLIT("<pkg>") - -instance Outputable PackageInfo where - -- Just used in debug prints of lex tokens and in debug modde - ppr pkg_info = ppr (packageInfoPackage pkg_info) -\end{code} - - %************************************************************************ %* * \subsection{Module locations} @@ -187,124 +103,54 @@ where the object file will reside if/when it is created. %************************************************************************ \begin{code} -newtype ModuleName = ModuleName EncodedFS +newtype Module = Module EncodedFS -- Haskell module names can include the quote character ', -- so the module names have the z-encoding applied to them -instance Binary ModuleName where - put_ bh (ModuleName m) = put_ bh m - get bh = do m <- get bh; return (ModuleName m) +instance Binary Module where + put_ bh (Module m) = put_ bh m + get bh = do m <- get bh; return (Module m) -instance Uniquable ModuleName where - getUnique (ModuleName nm) = getUnique nm +instance Uniquable Module where + getUnique (Module nm) = getUnique nm -instance Eq ModuleName where +instance Eq Module 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 ModuleName where +instance Ord Module where nm1 `compare` nm2 = getUnique nm1 `compare` getUnique nm2 -instance Outputable ModuleName where - ppr = pprModuleName - - -pprModuleName :: ModuleName -> SDoc -pprModuleName (ModuleName nm) = pprEncodedFS nm - -moduleNameFS :: ModuleName -> EncodedFS -moduleNameFS (ModuleName mod) = mod - -moduleNameString :: ModuleName -> EncodedString -moduleNameString (ModuleName mod) = unpackFS mod - -moduleNameUserString :: ModuleName -> UserString -moduleNameUserString (ModuleName mod) = decode (unpackFS mod) - --- used to be called mkSrcModule -mkModuleName :: UserString -> ModuleName -mkModuleName s = ModuleName (mkFastString (encode s)) - --- used to be called mkSrcModuleFS -mkModuleNameFS :: UserFS -> ModuleName -mkModuleNameFS s = ModuleName (encodeFS s) - --- used to be called mkSysModuleFS -mkSysModuleNameFS :: EncodedFS -> ModuleName -mkSysModuleNameFS s = ModuleName s -\end{code} - -\begin{code} instance Outputable Module where ppr = pprModule -instance Uniquable Module where - getUnique (Module nm _) = getUnique nm - --- Same if they have the same name. -instance Eq Module where - m1 == m2 = getUnique m1 == getUnique m2 - --- 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 - m1 `compare` m2 = getUnique m1 `compare` getUnique m2 -\end{code} - -\begin{code} pprModule :: Module -> SDoc -pprModule (Module mod p) = getPprStyle $ \ sty -> - if debugStyle sty then - -- Print the package too - -- Don't use '.' because it gets confused - -- with module names - brackets (ppr p) <> pprModuleName mod - else - pprModuleName mod -\end{code} - - -\begin{code} -mkModule :: PackageName -> ModuleName -> Module -mkModule pkg_name mod_name - = Module mod_name pkg_info - where - pkg_info - | opt_InPackage == pkg_name = ThisPackage - | otherwise = AnotherPackage - -mkBasePkgModule :: ModuleName -> Module -mkBasePkgModule mod_nm = mkModule basePackage mod_nm - -mkHomeModule :: ModuleName -> Module -mkHomeModule mod_nm = Module mod_nm ThisPackage - -isHomeModule :: Module -> Bool -isHomeModule (Module nm ThisPackage) = True -isHomeModule _ = False +pprModule (Module nm) = pprEncodedFS nm -mkPackageModule :: ModuleName -> Module -mkPackageModule mod_nm = Module mod_nm AnotherPackage +moduleFS :: Module -> EncodedFS +moduleFS (Module mod) = mod moduleString :: Module -> EncodedString -moduleString (Module (ModuleName fs) _) = unpackFS fs - -moduleName :: Module -> ModuleName -moduleName (Module mod pkg_info) = mod +moduleString (Module mod) = unpackFS mod moduleUserString :: Module -> UserString -moduleUserString (Module mod _) = moduleNameUserString mod +moduleUserString (Module mod) = decode (unpackFS mod) -printModulePrefix :: Module -> Bool - -- When printing, say M.x -printModulePrefix (Module nm ThisPackage) = False -printModulePrefix _ = True -\end{code} +-- used to be called mkSrcModule +mkModule :: UserString -> Module +mkModule s = Module (mkFastString (encode s)) +-- used to be called mkSrcModuleFS +mkModuleFS :: UserFS -> Module +mkModuleFS s = Module (encodeFS s) + +-- used to be called mkSysModuleFS +mkSysModuleFS :: EncodedFS -> Module +mkSysModuleFS s = Module s +\end{code} %************************************************************************ %* * @@ -314,9 +160,6 @@ printModulePrefix _ = True \begin{code} type ModuleEnv elt = UniqFM elt --- A ModuleName and Module have the same Unique, --- so both will work as keys. --- The 'ByName' variants work on ModuleNames emptyModuleEnv :: ModuleEnv a mkModuleEnv :: [(Module, a)] -> ModuleEnv a @@ -338,14 +181,8 @@ lookupWithDefaultModuleEnv :: ModuleEnv a -> a -> Module -> a elemModuleEnv :: Module -> ModuleEnv a -> Bool foldModuleEnv :: (a -> b -> b) -> b -> ModuleEnv a -> b --- The ByName variants -lookupModuleEnvByName :: ModuleEnv a -> ModuleName -> Maybe a -unitModuleEnvByName :: ModuleName -> a -> ModuleEnv a -extendModuleEnvByName :: ModuleEnv a -> ModuleName -> a -> ModuleEnv a - elemModuleEnv = elemUFM extendModuleEnv = addToUFM -extendModuleEnvByName = addToUFM extendModuleEnv_C = addToUFM_C extendModuleEnvList = addListToUFM plusModuleEnv_C = plusUFM_C @@ -353,20 +190,17 @@ delModuleEnvList = delListFromUFM delModuleEnv = delFromUFM plusModuleEnv = plusUFM lookupModuleEnv = lookupUFM -lookupModuleEnvByName = lookupUFM lookupWithDefaultModuleEnv = lookupWithDefaultUFM mapModuleEnv = mapUFM mkModuleEnv = listToUFM emptyModuleEnv = emptyUFM moduleEnvElts = eltsUFM unitModuleEnv = unitUFM -unitModuleEnvByName = unitUFM isEmptyModuleEnv = isNullUFM foldModuleEnv = foldUFM \end{code} \begin{code} - type ModuleSet = UniqSet Module mkModuleSet :: [Module] -> ModuleSet extendModuleSet :: ModuleSet -> Module -> ModuleSet diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index c440369916..f0ef363fa5 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -17,16 +17,16 @@ module Name ( mkExternalName, mkWiredInName, nameUnique, setNameUnique, - nameOccName, nameModule, nameModule_maybe, nameModuleName, + nameOccName, nameModule, nameModule_maybe, setNameOcc, hashName, localiseName, nameSrcLoc, nameParent, nameParent_maybe, isSystemName, isInternalName, isExternalName, - isTyVarName, isDllName, isWiredInName, isBuiltInSyntax, + isTyVarName, isWiredInName, isBuiltInSyntax, wiredInNameTyThing_maybe, - nameIsLocalOrFrom, isHomePackageName, + nameIsLocalOrFrom, -- Class NamedThing and overloaded friends NamedThing(..), @@ -38,8 +38,7 @@ module Name ( import {-# SOURCE #-} TypeRep( TyThing ) import OccName -- All of it -import Module ( Module, ModuleName, moduleName, isHomeModule ) -import CmdLineOpts ( opt_Static ) +import Module ( Module ) import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc ) import Unique ( Unique, Uniquable(..), getKey, pprUnique ) import Maybes ( orElse ) @@ -120,7 +119,6 @@ All built-in syntax is for wired-in things. nameUnique :: Name -> Unique nameOccName :: Name -> OccName nameModule :: Name -> Module -nameModuleName :: Name -> ModuleName nameSrcLoc :: Name -> SrcLoc nameUnique name = n_uniq name @@ -133,7 +131,6 @@ nameIsLocalOrFrom :: Module -> Name -> Bool isInternalName :: Name -> Bool isExternalName :: Name -> Bool isSystemName :: Name -> Bool -isHomePackageName :: Name -> Bool isWiredInName :: Name -> Bool isWiredInName (Name {n_sort = WiredIn _ _ _ _}) = True @@ -163,8 +160,6 @@ nameParent name = case nameParent_maybe name of Nothing -> name nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) -nameModuleName name = moduleName (nameModule name) - nameModule_maybe (Name { n_sort = External mod _}) = Just mod nameModule_maybe (Name { n_sort = WiredIn mod _ _ _}) = Just mod nameModule_maybe name = Nothing @@ -173,13 +168,6 @@ nameIsLocalOrFrom from name | isExternalName name = from == nameModule name | otherwise = True -isHomePackageName name - | isExternalName name = isHomeModule (nameModule name) - | otherwise = True -- Internal and system names - -isDllName :: Name -> Bool -- Does this name refer to something in a different DLL? -isDllName nm = not opt_Static && not (isHomePackageName nm) - isTyVarName :: Name -> Bool isTyVarName name = isTvOcc (nameOccName name) @@ -326,20 +314,18 @@ pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) Internal -> pprInternal sty uniq occ pprExternal sty uniq mod occ is_wired is_builtin - | codeStyle sty = ppr mod_name <> char '_' <> ppr_occ_name occ + | codeStyle sty = ppr mod <> char '_' <> ppr_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_name <> dot <> ppr_occ_name occ + | debugStyle sty = ppr mod <> dot <> ppr_occ_name occ <> braces (hsep [if is_wired then ptext SLIT("(w)") else empty, text (briefOccNameFlavour occ), pprUnique uniq]) | BuiltInSyntax <- is_builtin = ppr_occ_name occ -- never qualify builtin syntax - | unqualStyle sty mod_name occ = ppr_occ_name occ - | otherwise = ppr mod_name <> dot <> ppr_occ_name occ - where - mod_name = moduleName mod + | unqualStyle sty mod occ = ppr_occ_name occ + | otherwise = ppr mod <> dot <> ppr_occ_name occ pprInternal sty uniq occ | codeStyle sty = pprUnique uniq diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index a4e34d40e7..c4d71caa32 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -47,8 +47,8 @@ import OccName ( NameSpace, varName, elemOccEnv, plusOccEnv_C, extendOccEnv_C, foldOccEnv, occEnvElts ) -import Module ( ModuleName, mkModuleNameFS ) -import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe, +import Module ( Module, mkModuleFS ) +import Name ( Name, NamedThing(getName), nameModule, nameParent_maybe, nameOccName, isExternalName, nameSrcLoc ) import SrcLoc ( isGoodSrcLoc, SrcSpan ) import Outputable @@ -67,13 +67,13 @@ data RdrName = Unqual OccName -- Used for ordinary, unqualified occurrences - | Qual ModuleName OccName + | Qual Module OccName -- A qualified name written by the user in -- *source* code. The module isn't necessarily -- the module where the thing is defined; -- just the one from which it is imported - | Orig ModuleName OccName + | Orig Module OccName -- An original name; the module is the *defining* module. -- This is used when GHC generates code that will be fed -- into the renamer (e.g. from deriving clauses), but where @@ -97,10 +97,10 @@ data RdrName %************************************************************************ \begin{code} -rdrNameModule :: RdrName -> ModuleName +rdrNameModule :: RdrName -> Module rdrNameModule (Qual m _) = m rdrNameModule (Orig m _) = m -rdrNameModule (Exact n) = nameModuleName n +rdrNameModule (Exact n) = nameModule n rdrNameModule (Unqual n) = pprPanic "rdrNameModule" (ppr n) rdrNameOcc :: RdrName -> OccName @@ -121,7 +121,7 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ) setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ) setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ) -setRdrNameSpace (Exact n) ns = Orig (nameModuleName n) +setRdrNameSpace (Exact n) ns = Orig (nameModule n) (setOccNameSpace ns (nameOccName n)) \end{code} @@ -130,16 +130,16 @@ setRdrNameSpace (Exact n) ns = Orig (nameModuleName n) mkRdrUnqual :: OccName -> RdrName mkRdrUnqual occ = Unqual occ -mkRdrQual :: ModuleName -> OccName -> RdrName +mkRdrQual :: Module -> OccName -> RdrName mkRdrQual mod occ = Qual mod occ -mkOrig :: ModuleName -> OccName -> RdrName +mkOrig :: Module -> OccName -> RdrName mkOrig mod occ = Orig mod occ --------------- mkDerivedRdrName :: Name -> (OccName -> OccName) -> (RdrName) mkDerivedRdrName parent mk_occ - = mkOrig (nameModuleName parent) (mk_occ (nameOccName parent)) + = mkOrig (nameModule parent) (mk_occ (nameOccName parent)) --------------- -- These two are used when parsing source files @@ -151,7 +151,7 @@ mkVarUnqual :: UserFS -> RdrName mkVarUnqual n = Unqual (mkOccFS varName n) mkQual :: NameSpace -> (UserFS, UserFS) -> RdrName -mkQual sp (m, n) = Qual (mkModuleNameFS m) (mkOccFS sp n) +mkQual sp (m, n) = Qual (mkModuleFS m) (mkOccFS sp n) getRdrName :: NamedThing thing => thing -> RdrName getRdrName name = nameRdrName (getName name) @@ -164,7 +164,7 @@ nameRdrName name = Exact name nukeExact :: Name -> RdrName nukeExact n - | isExternalName n = Orig (nameModuleName n) (nameOccName n) + | isExternalName n = Orig (nameModule n) (nameOccName n) | otherwise = Unqual (nameOccName n) \end{code} @@ -368,7 +368,7 @@ unQualOK :: GlobalRdrElt -> Bool unQualOK (GRE {gre_prov = LocalDef _}) = True unQualOK (GRE {gre_prov = Imported is _}) = not (all is_qual is) -hasQual :: ModuleName -> GlobalRdrElt -> Bool +hasQual :: Module -> GlobalRdrElt -> Bool -- A qualified version of this thing is in scope hasQual mod (GRE {gre_prov = LocalDef m}) = m == mod hasQual mod (GRE {gre_prov = Imported is _}) = any ((== mod) . is_as) is @@ -411,7 +411,7 @@ The "provenance" of something says how it came to be in scope. \begin{code} data Provenance = LocalDef -- Defined locally - ModuleName + Module | Imported -- Imported [ImportSpec] -- INVARIANT: non-empty @@ -429,10 +429,10 @@ data ImportSpec -- Describes a particular import declaration -- Shared among all the Provenaces for a particular -- import declaration = ImportSpec { - is_mod :: ModuleName, -- 'import Muggle' + is_mod :: Module, -- 'import Muggle' -- Note the Muggle may well not be -- the defining module for this thing! - is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause) + is_as :: Module, -- 'as M' (or 'Muggle' if there is no 'as' clause) is_qual :: Bool, -- True <=> qualified (only) is_loc :: SrcSpan } -- Location of import statment diff --git a/ghc/compiler/cmm/CLabel.hs b/ghc/compiler/cmm/CLabel.hs index f50d406fa4..a18755f689 100644 --- a/ghc/compiler/cmm/CLabel.hs +++ b/ghc/compiler/cmm/CLabel.hs @@ -22,6 +22,16 @@ module CLabel ( mkStaticInfoTableLabel, mkApEntryLabel, mkApInfoTableLabel, + mkClosureTableLabel, + + mkLocalClosureLabel, + mkLocalInfoTableLabel, + mkLocalEntryLabel, + mkLocalConEntryLabel, + mkLocalStaticConEntryLabel, + mkLocalConInfoTableLabel, + mkLocalStaticInfoTableLabel, + mkLocalClosureTableLabel, mkReturnPtLabel, mkReturnInfoLabel, @@ -30,8 +40,6 @@ module CLabel ( mkBitmapLabel, mkStringLitLabel, - mkClosureTblLabel, - mkAsmTempLabel, mkModuleInitLabel, @@ -91,11 +99,11 @@ module CLabel ( #include "HsVersions.h" #include "../includes/ghcconfig.h" -import CmdLineOpts ( opt_Static, opt_DoTickyProfiling ) +import CmdLineOpts ( DynFlags, opt_Static, opt_DoTickyProfiling ) +import Packages ( isHomeModule ) import DataCon ( ConTag ) -import Module ( moduleName, moduleNameFS, - Module, isHomeModule ) -import Name ( Name, isDllName, isExternalName ) +import Module ( moduleFS, Module ) +import Name ( Name, isExternalName, nameModule ) import Unique ( pprUnique, Unique ) import PrimOp ( PrimOp ) import Config ( cLeadingUnderscore ) @@ -133,6 +141,10 @@ data CLabel Name -- definition of a particular Id or Con IdLabelInfo + | DynIdLabel -- like IdLabel, but in a separate package, + Name -- and might therefore need a dynamic + IdLabelInfo -- reference. + | CaseLabel -- A family of labels related to a particular -- case expression. {-# UNPACK #-} !Unique -- Unique says which case expression @@ -147,13 +159,16 @@ data CLabel | ModuleInitLabel Module -- the module name String -- its "way" + Bool -- True <=> is in a different package -- at some point we might want some kind of version number in -- the module init label, to guard against compiling modules in -- the wrong order. We can't use the interface file version however, -- because we don't always recompile modules which depend on a module -- whose version has changed. - | PlainModuleInitLabel Module -- without the vesrion & way info + | PlainModuleInitLabel -- without the vesrion & way info + Module + Bool -- True <=> is in a different package | ModuleRegdLabel @@ -187,7 +202,7 @@ data IdLabelInfo = Closure -- Label for closure | SRT -- Static reference table | SRTDesc -- Static reference table descriptor - | InfoTbl -- Info tables for closures; always read-only + | InfoTable -- Info tables for closures; always read-only | Entry -- entry point | Slow -- slow entry point @@ -197,9 +212,9 @@ data IdLabelInfo | Bitmap -- A bitmap (function or case return) | ConEntry -- constructor entry point - | ConInfoTbl -- corresponding info table + | ConInfoTable -- corresponding info table | StaticConEntry -- static constructor entry point - | StaticInfoTbl -- corresponding info table + | StaticInfoTable -- corresponding info table | ClosureTable -- table of closures for Enum tycons @@ -215,10 +230,10 @@ data CaseLabelInfo data RtsLabelInfo - = RtsSelectorInfoTbl Bool{-updatable-} Int{-offset-} -- Selector thunks + = RtsSelectorInfoTable Bool{-updatable-} Int{-offset-} -- Selector thunks | RtsSelectorEntry Bool{-updatable-} Int{-offset-} - | RtsApInfoTbl Bool{-updatable-} Int{-arity-} -- AP thunks + | RtsApInfoTable Bool{-updatable-} Int{-arity-} -- AP thunks | RtsApEntry Bool{-updatable-} Int{-arity-} | RtsPrimOp PrimOp @@ -254,21 +269,60 @@ data DynamicLinkerLabelInfo -- ----------------------------------------------------------------------------- -- Constructing CLabels -mkClosureLabel id = IdLabel id Closure -mkSRTLabel id = IdLabel id SRT -mkSRTDescLabel id = IdLabel id SRTDesc -mkInfoTableLabel id = IdLabel id InfoTbl -mkEntryLabel id = IdLabel id Entry -mkSlowEntryLabel id = IdLabel id Slow -mkBitmapLabel id = IdLabel id Bitmap -mkRednCountsLabel id = IdLabel id RednCounts +-- These are always local: +mkSRTLabel name = IdLabel name SRT +mkSRTDescLabel name = IdLabel name SRTDesc +mkSlowEntryLabel name = IdLabel name Slow +mkBitmapLabel name = IdLabel name Bitmap +mkRednCountsLabel name = IdLabel name RednCounts + +-- These have local & (possibly) external variants: +mkLocalClosureLabel name = IdLabel name Closure +mkLocalInfoTableLabel name = IdLabel name InfoTable +mkLocalEntryLabel name = IdLabel name Entry +mkLocalClosureTableLabel name = IdLabel name ClosureTable + +mkClosureLabel dflags name + | opt_Static || isHomeModule dflags mod = IdLabel name Closure + | otherwise = DynIdLabel name Closure + where mod = nameModule name + +mkInfoTableLabel dflags name + | opt_Static || isHomeModule dflags mod = IdLabel name InfoTable + | otherwise = DynIdLabel name InfoTable + where mod = nameModule name + +mkEntryLabel dflags name + | opt_Static || isHomeModule dflags mod = IdLabel name Entry + | otherwise = DynIdLabel name Entry + where mod = nameModule name + +mkClosureTableLabel dflags name + | opt_Static || isHomeModule dflags mod = IdLabel name ClosureTable + | otherwise = DynIdLabel name ClosureTable + where mod = nameModule name + +mkLocalConInfoTableLabel con = IdLabel con ConInfoTable +mkLocalConEntryLabel con = IdLabel con ConEntry +mkLocalStaticInfoTableLabel con = IdLabel con StaticInfoTable +mkLocalStaticConEntryLabel con = IdLabel con StaticConEntry + +mkConInfoTableLabel name False = IdLabel name ConInfoTable +mkConInfoTableLabel name True = DynIdLabel name ConInfoTable + +mkStaticInfoTableLabel name False = IdLabel name StaticInfoTable +mkStaticInfoTableLabel name True = DynIdLabel name StaticInfoTable + +mkConEntryLabel dflags name + | opt_Static || isHomeModule dflags mod = IdLabel name ConEntry + | otherwise = DynIdLabel name ConEntry + where mod = nameModule name + +mkStaticConEntryLabel dflags name + | opt_Static || isHomeModule dflags mod = IdLabel name StaticConEntry + | otherwise = DynIdLabel name StaticConEntry + where mod = nameModule name -mkConInfoTableLabel con = IdLabel con ConInfoTbl -mkConEntryLabel con = IdLabel con ConEntry -mkStaticInfoTableLabel con = IdLabel con StaticInfoTbl -mkStaticConEntryLabel con = IdLabel con StaticConEntry - -mkClosureTblLabel id = IdLabel id ClosureTable mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo @@ -278,8 +332,13 @@ mkDefaultLabel uniq = CaseLabel uniq CaseDefault mkStringLitLabel = StringLitLabel mkAsmTempLabel = AsmTempLabel -mkModuleInitLabel = ModuleInitLabel -mkPlainModuleInitLabel = PlainModuleInitLabel +mkModuleInitLabel :: DynFlags -> Module -> String -> CLabel +mkModuleInitLabel dflags mod way + = ModuleInitLabel mod way $! (not (isHomeModule dflags mod)) + +mkPlainModuleInitLabel :: DynFlags -> Module -> CLabel +mkPlainModuleInitLabel dflags mod + = PlainModuleInitLabel mod $! (not (isHomeModule dflags mod)) -- Some fixed runtime system labels @@ -301,10 +360,10 @@ mkRtsPrimOpLabel primop = RtsLabel (RtsPrimOp primop) moduleRegdLabel = ModuleRegdLabel -mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTbl upd off) +mkSelectorInfoLabel upd off = RtsLabel (RtsSelectorInfoTable upd off) mkSelectorEntryLabel upd off = RtsLabel (RtsSelectorEntry upd off) -mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTbl upd off) +mkApInfoTableLabel upd off = RtsLabel (RtsApInfoTable upd off) mkApEntryLabel upd off = RtsLabel (RtsApEntry upd off) -- Foreign labels @@ -352,9 +411,12 @@ mkPicBaseLabel = PicBaseLabel -- Converting info labels to entry labels. infoLblToEntryLbl :: CLabel -> CLabel -infoLblToEntryLbl (IdLabel n InfoTbl) = IdLabel n Entry -infoLblToEntryLbl (IdLabel n ConInfoTbl) = IdLabel n ConEntry -infoLblToEntryLbl (IdLabel n StaticInfoTbl) = IdLabel n StaticConEntry +infoLblToEntryLbl (IdLabel n InfoTable) = IdLabel n Entry +infoLblToEntryLbl (IdLabel n ConInfoTable) = IdLabel n ConEntry +infoLblToEntryLbl (IdLabel n StaticInfoTable) = IdLabel n StaticConEntry +infoLblToEntryLbl (DynIdLabel n InfoTable) = DynIdLabel n Entry +infoLblToEntryLbl (DynIdLabel n ConInfoTable) = DynIdLabel n ConEntry +infoLblToEntryLbl (DynIdLabel n StaticInfoTable) = DynIdLabel n StaticConEntry infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt infoLblToEntryLbl (RtsLabel (RtsInfo s)) = RtsLabel (RtsEntry s) infoLblToEntryLbl (RtsLabel (RtsRetInfo s)) = RtsLabel (RtsRet s) @@ -363,9 +425,12 @@ infoLblToEntryLbl (RtsLabel (RtsRetInfoFS s)) = RtsLabel (RtsRetFS s) infoLblToEntryLbl _ = panic "CLabel.infoLblToEntryLbl" entryLblToInfoLbl :: CLabel -> CLabel -entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTbl -entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTbl -entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTbl +entryLblToInfoLbl (IdLabel n Entry) = IdLabel n InfoTable +entryLblToInfoLbl (IdLabel n ConEntry) = IdLabel n ConInfoTable +entryLblToInfoLbl (IdLabel n StaticConEntry) = IdLabel n StaticInfoTable +entryLblToInfoLbl (DynIdLabel n Entry) = DynIdLabel n InfoTable +entryLblToInfoLbl (DynIdLabel n ConEntry) = DynIdLabel n ConInfoTable +entryLblToInfoLbl (DynIdLabel n StaticConEntry) = DynIdLabel n StaticInfoTable entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo entryLblToInfoLbl (RtsLabel (RtsEntry s)) = RtsLabel (RtsInfo s) entryLblToInfoLbl (RtsLabel (RtsRet s)) = RtsLabel (RtsRetInfo s) @@ -384,9 +449,10 @@ needsCDecl (IdLabel _ SRT) = False needsCDecl (IdLabel _ SRTDesc) = False needsCDecl (IdLabel _ Bitmap) = False needsCDecl (IdLabel _ _) = True +needsCDecl (DynIdLabel _ _) = True needsCDecl (CaseLabel _ _) = True -needsCDecl (ModuleInitLabel _ _) = True -needsCDecl (PlainModuleInitLabel _) = True +needsCDecl (ModuleInitLabel _ _ _) = True +needsCDecl (PlainModuleInitLabel _ _) = True needsCDecl ModuleRegdLabel = False needsCDecl (CaseLabel _ _) = False @@ -414,12 +480,13 @@ externallyVisibleCLabel :: CLabel -> Bool -- not C "static" externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (StringLitLabel _) = False externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (ModuleInitLabel _ _)= True -externallyVisibleCLabel (PlainModuleInitLabel _)= True +externallyVisibleCLabel (ModuleInitLabel _ _ _)= True +externallyVisibleCLabel (PlainModuleInitLabel _ _)= True externallyVisibleCLabel ModuleRegdLabel = False externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (ForeignLabel _ _ _) = True -externallyVisibleCLabel (IdLabel id _) = isExternalName id +externallyVisibleCLabel (IdLabel name _) = isExternalName name +externallyVisibleCLabel (DynIdLabel name _) = isExternalName name externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False @@ -434,8 +501,8 @@ data CLabelType | DataLabel labelType :: CLabel -> CLabelType -labelType (RtsLabel (RtsSelectorInfoTbl _ _)) = DataLabel -labelType (RtsLabel (RtsApInfoTbl _ _)) = DataLabel +labelType (RtsLabel (RtsSelectorInfoTable _ _)) = DataLabel +labelType (RtsLabel (RtsApInfoTable _ _)) = DataLabel labelType (RtsLabel (RtsData _)) = DataLabel labelType (RtsLabel (RtsCode _)) = CodeLabel labelType (RtsLabel (RtsInfo _)) = DataLabel @@ -450,21 +517,23 @@ labelType (RtsLabel (RtsRetInfoFS _)) = DataLabel labelType (RtsLabel (RtsRetFS _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel -labelType (ModuleInitLabel _ _) = CodeLabel -labelType (PlainModuleInitLabel _) = CodeLabel +labelType (ModuleInitLabel _ _ _) = CodeLabel +labelType (PlainModuleInitLabel _ _) = CodeLabel -labelType (IdLabel _ info) = +labelType (IdLabel _ info) = idInfoLabelType info +labelType (DynIdLabel _ info) = idInfoLabelType info +labelType _ = DataLabel + +idInfoLabelType info = case info of - InfoTbl -> DataLabel + InfoTable -> DataLabel Closure -> DataLabel Bitmap -> DataLabel - ConInfoTbl -> DataLabel - StaticInfoTbl -> DataLabel + ConInfoTable -> DataLabel + StaticInfoTable -> DataLabel ClosureTable -> DataLabel _ -> CodeLabel -labelType _ = DataLabel - -- ----------------------------------------------------------------------------- -- Does a CLabel need dynamic linkage? @@ -478,7 +547,8 @@ labelDynamic :: CLabel -> Bool labelDynamic lbl = case lbl of RtsLabel _ -> not opt_Static -- i.e., is the RTS in a DLL or not? - IdLabel n k -> isDllName n + IdLabel n k -> False + DynIdLabel n k -> True #if mingw32_TARGET_OS ForeignLabel _ _ d -> d #else @@ -486,8 +556,8 @@ labelDynamic lbl = -- so we claim that all foreign imports come from dynamic libraries ForeignLabel _ _ _ -> True #endif - ModuleInitLabel m _ -> (not opt_Static) && (not (isHomeModule m)) - PlainModuleInitLabel m -> (not opt_Static) && (not (isHomeModule m)) + ModuleInitLabel m _ dyn -> not opt_Static && dyn + PlainModuleInitLabel m dyn -> not opt_Static && dyn -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False @@ -595,7 +665,7 @@ pprCLbl (RtsLabel (RtsData str)) = ptext str pprCLbl (RtsLabel (RtsCodeFS str)) = ftext str pprCLbl (RtsLabel (RtsDataFS str)) = ftext str -pprCLbl (RtsLabel (RtsSelectorInfoTbl upd_reqd offset)) +pprCLbl (RtsLabel (RtsSelectorInfoTable upd_reqd offset)) = hcat [ptext SLIT("stg_sel_"), text (show offset), ptext (if upd_reqd then SLIT("_upd_info") @@ -609,7 +679,7 @@ pprCLbl (RtsLabel (RtsSelectorEntry upd_reqd offset)) else SLIT("_noupd_entry")) ] -pprCLbl (RtsLabel (RtsApInfoTbl upd_reqd arity)) +pprCLbl (RtsLabel (RtsApInfoTable upd_reqd arity)) = hcat [ptext SLIT("stg_ap_"), text (show arity), ptext (if upd_reqd then SLIT("_upd_info") @@ -659,16 +729,17 @@ pprCLbl ModuleRegdLabel pprCLbl (ForeignLabel str _ _) = ftext str -pprCLbl (IdLabel id flavor) = ppr id <> ppIdFlavor flavor +pprCLbl (IdLabel name flavor) = ppr name <> ppIdFlavor flavor +pprCLbl (DynIdLabel name flavor) = ppr name <> ppIdFlavor flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs -pprCLbl (ModuleInitLabel mod way) - = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) +pprCLbl (ModuleInitLabel mod way _) + = ptext SLIT("__stginit_") <> ftext (moduleFS mod) <> char '_' <> text way -pprCLbl (PlainModuleInitLabel mod) - = ptext SLIT("__stginit_") <> ftext (moduleNameFS (moduleName mod)) +pprCLbl (PlainModuleInitLabel mod _) + = ptext SLIT("__stginit_") <> ftext (moduleFS mod) ppIdFlavor :: IdLabelInfo -> SDoc ppIdFlavor x = pp_cSEP <> @@ -676,15 +747,15 @@ ppIdFlavor x = pp_cSEP <> Closure -> ptext SLIT("closure") SRT -> ptext SLIT("srt") SRTDesc -> ptext SLIT("srtd") - InfoTbl -> ptext SLIT("info") + InfoTable -> ptext SLIT("info") Entry -> ptext SLIT("entry") Slow -> ptext SLIT("slow") RednCounts -> ptext SLIT("ct") Bitmap -> ptext SLIT("btm") ConEntry -> ptext SLIT("con_entry") - ConInfoTbl -> ptext SLIT("con_info") + ConInfoTable -> ptext SLIT("con_info") StaticConEntry -> ptext SLIT("static_entry") - StaticInfoTbl -> ptext SLIT("static_info") + StaticInfoTable -> ptext SLIT("static_info") ClosureTable -> ptext SLIT("closure_tbl") ) diff --git a/ghc/compiler/cmm/CmmParse.y b/ghc/compiler/cmm/CmmParse.y index 7eb4bdbfde..4b25d45e54 100644 --- a/ghc/compiler/cmm/CmmParse.y +++ b/ghc/compiler/cmm/CmmParse.y @@ -25,11 +25,11 @@ import CostCentre ( dontCareCCS ) import Cmm import PprCmm -import CmmUtils ( mkIntCLit, mkLblExpr ) +import CmmUtils ( mkIntCLit ) import CmmLex import CLabel import MachOp -import SMRep ( tablesNextToCode, fixedHdrSize, CgRep(..) ) +import SMRep ( fixedHdrSize, CgRep(..) ) import Lexer import ForeignCall ( CCallConv(..) ) @@ -872,7 +872,7 @@ parseCmmFile dflags filename = do case unP cmmParse init_state of PFailed span err -> do printError span err; return Nothing POk _ code -> do - cmm <- initC no_module (getCmm (unEC code initEnv [] >> return ())) + cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ())) dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm]) return (Just cmm) where diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index 5a953500a0..2254ff7df9 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -236,7 +236,12 @@ getCgIdInfo id Nothing -> -- Should be imported; make up a CgIdInfo for it - if isExternalName name then + let + name = idName id + in + if isExternalName name then do + dflags <- getDynFlags + let ext_lbl = CmmLit (CmmLabel (mkClosureLabel dflags name)) return (stableIdInfo id ext_lbl (mkLFImported id)) else if isVoidArg (idCgRep id) then @@ -246,9 +251,7 @@ getCgIdInfo id -- Bug cgLookupPanic id }}}} - where - name = idName id - ext_lbl = CmmLit (CmmLabel (mkClosureLabel name)) + cgLookupPanic :: Id -> FCode a cgLookupPanic id diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index bdacd27ebd..82bdec31b8 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.71 2004/09/30 10:35:36 simonpj Exp $ +% $Id: CgCase.lhs,v 1.72 2004/11/26 16:19:59 simonmar Exp $ % %******************************************************** %* * @@ -336,9 +336,10 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts -- Bind the default binder if necessary -- (avoiding it avoids the assignment) -- The deadness info is set by StgVarInfo + ; dflags <- getDynFlags ; whenC (not (isDeadBinder bndr)) (do { tmp_reg <- bindNewToTemp bndr - ; stmtC (CmmAssign tmp_reg (tagToClosure tycon tag_amode)) }) + ; stmtC (CmmAssign tmp_reg (tagToClosure dflags tycon tag_amode)) }) -- Compile the alts ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-} diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 0c6ca4b76f..0369b1ba03 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.64 2004/09/30 10:35:39 simonpj Exp $ +% $Id: CgClosure.lhs,v 1.65 2004/11/26 16:20:03 simonmar Exp $ % \section[CgClosure]{Code generation for closures} @@ -40,8 +40,7 @@ import MachOp ( MachHint(..) ) import Cmm import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts, mkLblExpr ) -import CLabel ( mkRtsDataLabel, mkClosureLabel, mkRednCountsLabel, - mkSlowEntryLabel, mkIndStaticInfoLabel ) +import CLabel import StgSyn import CmdLineOpts ( opt_DoTickyProfiling ) import CostCentre @@ -83,7 +82,7 @@ cgTopRhsClosure id ccs binder_info srt upd_flag args body = do ; mod_name <- moduleName ; let descr = closureDescription mod_name name closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr - closure_label = mkClosureLabel name + closure_label = mkLocalClosureLabel name cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info closure_rep = mkStaticClosureFields closure_info ccs True [] @@ -366,7 +365,7 @@ mkSlowEntryCode cl_info reg_args stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) - jump_to_entry = CmmJump (mkLblExpr (enterIdLabel name)) [] + jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) [] \end{code} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 7dc5d75b41..9a9f11aa4d 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -35,7 +35,7 @@ import CgTailCall ( performReturn, emitKnownConReturnCode, returnUnboxedTuple ) import CgProf ( mkCCostCentreStack, ldvEnter, curCCS ) import CgTicky import CgInfoTbls ( emitClosureCodeAndInfoTable, dataConTagZ ) -import CLabel ( mkClosureLabel, mkRtsDataLabel, mkClosureTblLabel ) +import CLabel import ClosureInfo ( mkConLFInfo, mkLFArgument ) import CmmUtils ( mkLblExpr ) import Cmm @@ -70,17 +70,20 @@ cgTopRhsCon :: Id -- Name of thing bound to this RHS -> [StgArg] -- Args -> FCode (Id, CgIdInfo) cgTopRhsCon id con args - = ASSERT( not (isDllConApp con args) ) - ASSERT( args `lengthIs` dataConRepArity con ) - do { -- LAY IT OUT + = do { + ; dflags <- getDynFlags + ; ASSERT( not (isDllConApp dflags con args) ) return () + ; ASSERT( args `lengthIs` dataConRepArity con ) return () + + -- LAY IT OUT ; amodes <- getArgAmodes args ; let name = idName id lf_info = mkConLFInfo con - closure_label = mkClosureLabel name + closure_label = mkClosureLabel dflags name caffy = any stgArgHasCafRefs args - (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes + (closure_info, amodes_w_offsets) = layOutStaticConstr dflags con amodes closure_rep = mkStaticClosureFields closure_info dontCareCCS -- Because it's static data @@ -137,8 +140,9 @@ at all. \begin{code} buildDynCon binder cc con [] - = returnFC (stableIdInfo binder - (mkLblExpr (mkClosureLabel (dataConName con))) + = do dflags <- getDynFlags + returnFC (stableIdInfo binder + (mkLblExpr (mkClosureLabel dflags (dataConName con))) (mkConLFInfo con)) \end{code} @@ -191,11 +195,15 @@ Now the general case. \begin{code} buildDynCon binder ccs con args - = do { hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets + = do { + ; dflags <- getDynFlags + ; let + (closure_info, amodes_w_offsets) = layOutDynConstr dflags con args + + ; hp_off <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets ; returnFC (heapIdInfo binder hp_off lf_info) } where lf_info = mkConLFInfo con - (closure_info, amodes_w_offsets) = layOutDynConstr con args use_cc -- cost-centre to stick in the object | currentOrSubsumedCCS ccs = curCCS @@ -220,11 +228,13 @@ found a $con$. \begin{code} bindConArgs :: DataCon -> [Id] -> Code bindConArgs con args - = ASSERT(not (isUnboxedTupleCon con)) - mapCs bind_arg args_w_offsets - where - bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg) - (_, args_w_offsets) = layOutDynConstr con (addIdReps args) + = do dflags <- getDynFlags + let + bind_arg (arg, offset) = bindNewToNode arg offset (mkLFArgument arg) + (_, args_w_offsets) = layOutDynConstr dflags con (addIdReps args) + -- + ASSERT(not (isUnboxedTupleCon con)) return () + mapCs bind_arg args_w_offsets \end{code} Unboxed tuples are handled slightly differently - the object is @@ -385,9 +395,9 @@ cgTyCon tycon -- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff ; extra <- if isEnumerationTyCon tycon then do - tbl <- getCmm (emitRODataLits (mkClosureTblLabel + tbl <- getCmm (emitRODataLits (mkLocalClosureTableLabel (tyConName tycon)) - [ CmmLabel (mkClosureLabel (dataConName con)) + [ CmmLabel (mkLocalClosureLabel (dataConName con)) | con <- tyConDataCons tycon]) return [tbl] else @@ -404,32 +414,41 @@ static closure, for a constructor. cgDataCon :: DataCon -> Code cgDataCon data_con = do { -- Don't need any dynamic closure code for zero-arity constructors - whenC (not (isNullaryRepDataCon data_con)) + dflags <- getDynFlags + + ; let + -- To allow the debuggers, interpreters, etc to cope with + -- static data structures (ie those built at compile + -- time), we take care that info-table contains the + -- information we need. + (static_cl_info, _) = + layOutStaticConstr dflags data_con arg_reps + + (dyn_cl_info, arg_things) = + layOutDynConstr dflags data_con arg_reps + + emit_info cl_info ticky_code + = do { code_blks <- getCgStmts the_code + ; emitClosureCodeAndInfoTable cl_info [] code_blks } + where + the_code = do { ticky_code + ; ldvEnter (CmmReg nodeReg) + ; body_code } + + arg_reps :: [(CgRep, Type)] + arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con] + + body_code = do { + -- NB: We don't set CC when entering data (WDP 94/06) + tickyReturnOldCon (length arg_things) + ; performReturn (emitKnownConReturnCode data_con) } + -- noStmts: Ptr to thing already in Node + + ; whenC (not (isNullaryRepDataCon data_con)) (emit_info dyn_cl_info tickyEnterDynCon) -- Dynamic-Closure first, to reduce forward references ; emit_info static_cl_info tickyEnterStaticCon } where - emit_info cl_info ticky_code - = do { code_blks <- getCgStmts the_code - ; emitClosureCodeAndInfoTable cl_info [] code_blks } - where - the_code = do { ticky_code - ; ldvEnter (CmmReg nodeReg) - ; body_code } - - arg_reps :: [(CgRep, Type)] - arg_reps = [(typeCgRep ty, ty) | ty <- dataConRepArgTys data_con] - - -- To allow the debuggers, interpreters, etc to cope with static - -- data structures (ie those built at compile time), we take care that - -- info-table contains the information we need. - (static_cl_info, _) = layOutStaticConstr data_con arg_reps - (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps - - body_code = do { -- NB: We don't set CC when entering data (WDP 94/06) - tickyReturnOldCon (length arg_things) - ; performReturn (emitKnownConReturnCode data_con) } - -- noStmts: Ptr to thing already in Node \end{code} diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index ff405319c4..459f2c011f 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.60 2004/09/30 10:35:43 simonpj Exp $ +% $Id: CgExpr.lhs,v 1.61 2004/11/26 16:20:07 simonmar Exp $ % %******************************************************** %* * @@ -152,7 +152,8 @@ cgExpr (StgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty) do { (_,amode) <- getArgAmode arg ; amode' <- assignTemp amode -- We're going to use it twice, -- so save in a temp if non-trivial - ; stmtC (CmmAssign nodeReg (tagToClosure tycon amode')) + ; dflags <- getDynFlags + ; stmtC (CmmAssign nodeReg (tagToClosure dflags tycon amode')) ; performReturn (emitAlgReturnCode tycon amode') } where -- If you're reading this code in the attempt to figure @@ -184,8 +185,9 @@ cgExpr x@(StgOpApp op@(StgPrimOp primop) args res_ty) | ReturnsAlg tycon <- result_info, isEnumerationTyCon tycon -- c.f. cgExpr (...TagToEnumOp...) = do tag_reg <- newTemp wordRep + dflags <- getDynFlags cgPrimOp [tag_reg] primop args emptyVarSet - stmtC (CmmAssign nodeReg (tagToClosure tycon (CmmReg tag_reg))) + stmtC (CmmAssign nodeReg (tagToClosure dflags tycon (CmmReg tag_reg))) performReturn (emitAlgReturnCode tycon (CmmReg tag_reg)) where result_info = getPrimOpResultInfo primop @@ -280,7 +282,8 @@ cgRhs name (StgRhsCon maybe_cc con args) ; returnFC (name, idinfo) } cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = mkRhsClosure name cc bi srt fvs upd_flag args body + = do dflags <- getDynFlags + mkRhsClosure dflags name cc bi srt fvs upd_flag args body \end{code} mkRhsClosure looks for two special forms of the right-hand side: @@ -303,7 +306,7 @@ form: \begin{code} -mkRhsClosure bndr cc bi srt +mkRhsClosure dflags bndr cc bi srt [the_fv] -- Just one free var upd_flag -- Updatable thunk [] -- A thunk @@ -323,9 +326,10 @@ mkRhsClosure bndr cc bi srt -- will evaluate to. cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv] where - lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag) - (_, params_w_offsets) = layOutDynConstr con (addIdReps params) - -- Just want the layout + lf_info = mkSelectorLFInfo bndr offset_into_int + (isUpdatable upd_flag) + (_, params_w_offsets) = layOutDynConstr dflags con (addIdReps params) + -- Just want the layout maybe_offset = assocMaybe params_w_offsets selectee Just the_offset = maybe_offset offset_into_int = the_offset - fixedHdrSize @@ -348,7 +352,7 @@ We only generate an Ap thunk if all the free variables are pointers, for semi-obvious reasons. \begin{code} -mkRhsClosure bndr cc bi srt +mkRhsClosure dflags bndr cc bi srt fvs upd_flag [] -- No args; a thunk @@ -373,7 +377,7 @@ mkRhsClosure bndr cc bi srt The default case ~~~~~~~~~~~~~~~~ \begin{code} -mkRhsClosure bndr cc bi srt fvs upd_flag args body +mkRhsClosure dflags bndr cc bi srt fvs upd_flag args body = cgRhsClosure bndr cc bi srt fvs upd_flag args body \end{code} diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs index 5e6c122f7c..58fbe947ac 100644 --- a/ghc/compiler/codeGen/CgHeapery.lhs +++ b/ghc/compiler/codeGen/CgHeapery.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgHeapery.lhs,v 1.41 2004/09/30 10:35:45 simonpj Exp $ +% $Id: CgHeapery.lhs,v 1.42 2004/11/26 16:20:09 simonmar Exp $ % \section[CgHeapery]{Heap management functions} @@ -54,6 +54,7 @@ import TyCon ( tyConPrimRep ) import CostCentre ( CostCentreStack ) import Util ( mapAccumL, filterOut ) import Constants ( wORD_SIZE ) +import CmdLineOpts ( DynFlags ) import Outputable import GLAEXTS @@ -125,7 +126,8 @@ getHpRelOffset virtual_offset \begin{code} layOutDynConstr, layOutStaticConstr - :: DataCon + :: DynFlags + -> DataCon -> [(CgRep,a)] -> (ClosureInfo, [(a,VirtualHpOffset)]) @@ -133,8 +135,8 @@ layOutDynConstr, layOutStaticConstr layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True -layOutConstr is_static data_con args - = (mkConInfo is_static data_con tot_wds ptr_wds, +layOutConstr is_static dflags data_con args + = (mkConInfo dflags is_static data_con tot_wds ptr_wds, things_w_offsets) where (tot_wds, -- #ptr_wds + #nonptr_wds diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs index f6b209672a..d9d0801a03 100644 --- a/ghc/compiler/codeGen/CgMonad.lhs +++ b/ghc/compiler/codeGen/CgMonad.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgMonad.lhs,v 1.41 2004/09/10 14:53:47 simonmar Exp $ +% $Id: CgMonad.lhs,v 1.42 2004/11/26 16:20:10 simonmar Exp $ % \section[CgMonad]{The code generation monad} @@ -47,7 +47,7 @@ module CgMonad ( Sequel(..), -- ToDo: unabstract? -- ideally we wouldn't export these, but some other modules access internal state - getState, setState, getInfoDown, + getState, setState, getInfoDown, getDynFlags, -- more localised access to monad state getStkUsage, setStkUsage, @@ -61,6 +61,7 @@ module CgMonad ( import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) +import CmdLineOpts ( DynFlags ) import Cmm import CmmUtils ( CmmStmts, isNopStmt ) import CLabel @@ -75,6 +76,8 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply, uniqFromSupp import FastString import Outputable +import Control.Monad ( liftM ) + infixr 9 `thenC` -- Right-associative! infixr 9 `thenFC` \end{code} @@ -92,6 +95,7 @@ along. \begin{code} data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { + cgd_dflags :: DynFlags, cgd_mod :: Module, -- Module being compiled cgd_statics :: CgBindings, -- [Id -> info] : static environment cgd_srt :: CLabel, -- label of the current SRT @@ -99,9 +103,10 @@ data CgInfoDownwards -- information only passed *downwards* by the monad cgd_eob :: EndOfBlockInfo -- Info for stuff to do at end of basic block: } -initCgInfoDown :: Module -> CgInfoDownwards -initCgInfoDown mod - = MkCgInfoDown { cgd_mod = mod, +initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards +initCgInfoDown dflags mod + = MkCgInfoDown { cgd_dflags = dflags, + cgd_mod = mod, cgd_statics = emptyVarEnv, cgd_srt = error "initC: srt", cgd_ticky = mkTopTickyCtrLabel, @@ -370,11 +375,11 @@ instance Monad FCode where The Abstract~C is not in the environment so as to improve strictness. \begin{code} -initC :: Module -> FCode a -> IO a +initC :: DynFlags -> Module -> FCode a -> IO a -initC mod (FCode code) +initC dflags mod (FCode code) = do { uniqs <- mkSplitUniqSupply 'c' - ; case code (initCgInfoDown mod) (initCgState uniqs) of + ; case code (initCgInfoDown dflags mod) (initCgState uniqs) of (res, _) -> return res } @@ -499,6 +504,9 @@ newUnique = do getInfoDown :: FCode CgInfoDownwards getInfoDown = FCode $ \info_down state -> (info_down,state) +getDynFlags :: FCode DynFlags +getDynFlags = liftM cgd_dflags getInfoDown + withInfoDown :: FCode a -> CgInfoDownwards -> FCode a withInfoDown (FCode fcode) info_down = FCode $ \_ state -> fcode info_down state @@ -646,7 +654,7 @@ forkEvalHelp :: EndOfBlockInfo -- For the body a) -- Result of the FCode -- A disturbingly complicated function forkEvalHelp body_eob_info env_code body_code - = do { info_down@(MkCgInfoDown cg_info statics srt ticky _) <- getInfoDown + = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState ; let { info_down_for_body = info_down {cgd_eob = body_eob_info} diff --git a/ghc/compiler/codeGen/CgProf.hs b/ghc/compiler/codeGen/CgProf.hs index 84061e41ed..d54718f495 100644 --- a/ghc/compiler/codeGen/CgProf.hs +++ b/ghc/compiler/codeGen/CgProf.hs @@ -43,7 +43,7 @@ import MachOp import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr ) import CLabel ( mkCCLabel, mkCCSLabel, mkRtsDataLabel ) -import Module ( moduleNameUserString ) +import Module ( moduleUserString ) import Id ( Id ) import CostCentre import StgSyn ( GenStgExpr(..), StgExpr ) @@ -291,7 +291,7 @@ emitCostCentreDecl -> Code emitCostCentreDecl cc = do { label <- mkStringCLit (costCentreUserName cc) - ; modl <- mkStringCLit (moduleNameUserString (cc_mod cc)) + ; modl <- mkStringCLit (moduleUserString (cc_mod cc)) ; let lits = [ zero, -- StgInt ccID, label, -- char *label, diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs index 98c075d31d..0b77823560 100644 --- a/ghc/compiler/codeGen/CgTailCall.lhs +++ b/ghc/compiler/codeGen/CgTailCall.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgTailCall.lhs,v 1.40 2004/09/30 10:35:50 simonpj Exp $ +% $Id: CgTailCall.lhs,v 1.41 2004/11/26 16:20:12 simonmar Exp $ % %******************************************************** %* * @@ -118,8 +118,9 @@ performTailCall fun_info arg_amodes pending_assts opt_node_asst | nodeMustPointToIt lf_info = node_asst | otherwise = noStmts ; EndOfBlockInfo sp _ <- getEndOfBlockInfo + ; dflags <- getDynFlags - ; case (getCallMethod fun_name lf_info (length arg_amodes)) of + ; case (getCallMethod dflags fun_name lf_info (length arg_amodes)) of -- Node must always point to things we enter EnterIt -> do diff --git a/ghc/compiler/codeGen/CgUtils.hs b/ghc/compiler/codeGen/CgUtils.hs index 9727fec38f..a8e9c39ae8 100644 --- a/ghc/compiler/codeGen/CgUtils.hs +++ b/ghc/compiler/codeGen/CgUtils.hs @@ -52,10 +52,11 @@ import CLabel ( CLabel, mkStringLitLabel ) import Digraph ( SCC(..), stronglyConnComp ) import ListSetOps ( assocDefault ) import Util ( filterOut, sortLe ) -import Char ( ord ) +import CmdLineOpts ( DynFlags ) import FastString ( LitString, FastString, unpackFS ) import Outputable +import Char ( ord ) import DATA_BITS import Maybe ( isNothing ) @@ -211,10 +212,11 @@ addToMemE rep ptr n -- ------------------------------------------------------------------------- -tagToClosure :: TyCon -> CmmExpr -> CmmExpr -tagToClosure tycon tag +tagToClosure :: DynFlags -> TyCon -> CmmExpr -> CmmExpr +tagToClosure dflags tycon tag = CmmLoad (cmmOffsetExprW closure_tbl tag) wordRep - where closure_tbl = CmmLit (CmmLabel (mkClosureTblLabel (tyConName tycon))) + where closure_tbl = CmmLit (CmmLabel lbl) + lbl = mkClosureTableLabel dflags (tyConName tycon) ------------------------------------------------------------------------- -- diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 147039b344..f1b2540526 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -33,7 +33,7 @@ module ClosureInfo ( closureSingleEntry, closureReEntrant, isConstrClosure_maybe, closureFunInfo, isStandardFormThunk, isKnownFun, - enterIdLabel, enterReturnPtLabel, + enterIdLabel, enterLocalIdLabel, enterReturnPtLabel, nodeMustPointToIt, CallMethod(..), getCallMethod, @@ -61,7 +61,8 @@ import SMRep -- all of it import CLabel import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject ) -import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, +import Packages ( isDllName ) +import CmdLineOpts ( DynFlags, opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling, opt_SMP ) import Id ( Id, idType, idArity, idName ) @@ -114,7 +115,8 @@ data ClosureInfo -- the constructor's info table), and they don't have an SRT. | ConInfo { closureCon :: !DataCon, - closureSMRep :: !SMRep + closureSMRep :: !SMRep, + closureDllCon :: !Bool -- is in a separate DLL } -- C_SRT is what StgSyn.SRT gets translated to... @@ -318,13 +320,15 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds -mkConInfo :: Bool -- Is static +mkConInfo :: DynFlags + -> Bool -- Is static -> DataCon -> Int -> Int -- Total and pointer words -> ClosureInfo -mkConInfo is_static data_con tot_wds ptr_wds +mkConInfo dflags is_static data_con tot_wds ptr_wds = ConInfo { closureSMRep = sm_rep, - closureCon = data_con } + closureCon = data_con, + closureDllCon = isDllName dflags (dataConName data_con) } where sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds \end{code} @@ -557,29 +561,30 @@ data CallMethod CLabel -- The code label Int -- Its arity -getCallMethod :: Name -- Function being applied +getCallMethod :: DynFlags + -> Name -- Function being applied -> LambdaFormInfo -- Its info -> Int -- Number of available arguments -> CallMethod -getCallMethod name lf_info n_args +getCallMethod dflags 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 name (LFReEntrant _ arity _ _) n_args +getCallMethod dflags 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 name) arity + | otherwise = DirectEntry (enterIdLabel dflags name) arity -getCallMethod name (LFCon con) n_args +getCallMethod dflags name (LFCon con) n_args = ASSERT( n_args == 0 ) ReturnCon con -getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args +getCallMethod dflags 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] @@ -592,24 +597,24 @@ getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args | otherwise -- Jump direct to code for single-entry thunks = ASSERT( n_args == 0 ) - JumpToIt (thunkEntryLabel name std_form_info updatable) + JumpToIt (thunkEntryLabel dflags name std_form_info updatable) -getCallMethod name (LFUnknown True) n_args +getCallMethod dflags name (LFUnknown True) n_args = SlowCall -- might be a function -getCallMethod name (LFUnknown False) n_args +getCallMethod dflags name (LFUnknown False) n_args = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod name (LFBlackHole _) n_args +getCallMethod dflags 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 name (LFLetNoEscape 0) n_args +getCallMethod dflags name (LFLetNoEscape 0) n_args = JumpToIt (enterReturnPtLabel (nameUnique name)) -getCallMethod name (LFLetNoEscape arity) n_args +getCallMethod dflags name (LFLetNoEscape arity) n_args | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) @@ -810,35 +815,33 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> mkInfoTableLabel name + LFThunk{} -> mkLocalInfoTableLabel name - LFReEntrant _ _ _ _ -> mkInfoTableLabel name + LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name other -> panic "infoTableLabelFromCI" -infoTableLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep }) - = mkConInfoPtr con rep - - -mkConInfoPtr :: DataCon -> SMRep -> CLabel -mkConInfoPtr con rep - | isStaticRep rep = mkStaticInfoTableLabel name - | otherwise = mkConInfoTableLabel name +infoTableLabelFromCI (ConInfo { closureCon = con, + closureSMRep = rep, + closureDllCon = dll }) + | isStaticRep rep = mkStaticInfoTableLabel name dll + | otherwise = mkConInfoTableLabel name dll where name = dataConName con -closureLabelFromCI (ClosureInfo { closureName = nm }) = mkClosureLabel nm +-- ClosureInfo for a closure (as opposed to a constructor) is always local +closureLabelFromCI (ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm closureLabelFromCI _ = panic "closureLabelFromCI" -- thunkEntryLabel is a local help function, not exported. It's used from both -- entryLabelFromCI and getCallMethod. -thunkEntryLabel thunk_id (ApThunk arity) is_updatable +thunkEntryLabel dflags thunk_id (ApThunk arity) is_updatable = enterApLabel is_updatable arity -thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag +thunkEntryLabel dflags thunk_id (SelectorThunk offset) upd_flag = enterSelectorLabel upd_flag offset -thunkEntryLabel thunk_id _ is_updatable - = enterIdLabel thunk_id +thunkEntryLabel dflags thunk_id _ is_updatable + = enterIdLabel dflags thunk_id enterApLabel is_updatable arity | tablesNextToCode = mkApInfoTableLabel is_updatable arity @@ -848,9 +851,13 @@ enterSelectorLabel upd_flag offset | tablesNextToCode = mkSelectorInfoLabel upd_flag offset | otherwise = mkSelectorEntryLabel upd_flag offset -enterIdLabel id - | tablesNextToCode = mkInfoTableLabel id - | otherwise = mkEntryLabel id +enterIdLabel dflags id + | tablesNextToCode = mkInfoTableLabel dflags id + | otherwise = mkEntryLabel dflags id + +enterLocalIdLabel id + | tablesNextToCode = mkLocalInfoTableLabel id + | otherwise = mkLocalEntryLabel id enterReturnPtLabel name | tablesNextToCode = mkReturnInfoLabel name diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 7ee581a45f..056fb1ef50 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -33,15 +33,14 @@ import CgClosure ( cgTopRhsClosure ) import CgCon ( cgTopRhsCon, cgTyCon ) import CgUtils ( cmmRegOffW, emitRODataLits, cmmNeWord, emitRtsCall ) -import CLabel ( mkSRTLabel, mkClosureLabel, moduleRegdLabel, - mkPlainModuleInitLabel, mkModuleInitLabel ) +import CLabel import Cmm import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr ) import PprCmm ( pprCmms ) import MachOp ( wordRep, MachHint(..) ) import StgSyn -import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN_Name, pREL_TOP_HANDLER ) +import PrelNames ( gHC_PRIM, rOOT_MAIN, mAIN, pREL_TOP_HANDLER ) import CmdLineOpts ( DynFlags, DynFlag(..), opt_EnsureSplittableC, opt_SccProfilingOn ) @@ -51,10 +50,9 @@ import Id ( Id, idName, setIdName ) import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalName ) import OccName ( mkLocalOcc ) import TyCon ( isDataTyCon ) -import Module ( Module, mkModuleName ) +import Module ( Module, mkModule ) import ErrUtils ( dumpIfSet_dyn, showPass ) import Panic ( assertPanic ) -import qualified Module ( moduleName ) #ifdef DEBUG import Outputable @@ -86,14 +84,14 @@ codeGen dflags this_mod type_env foreign_stubs imported_mods -- Why? -- ; mapM_ (\x -> seq x (return ())) data_tycons - ; code_stuff <- initC this_mod $ do - { cmm_binds <- mapM (getCmm . cgTopBinding) stg_binds - ; cmm_tycons <- mapM cgTyCon data_tycons - ; cmm_init <- getCmm (mkModuleInit way cost_centre_info - this_mod mb_main_mod - foreign_stubs imported_mods) - ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) - } + ; 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 way cost_centre_info + this_mod mb_main_mod + foreign_stubs imported_mods) + ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) + } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in @@ -149,14 +147,15 @@ We initialise the module tree by keeping a work-stack, \begin{code} mkModuleInit - :: String -- the "way" + :: DynFlags + -> String -- the "way" -> CollectedCCs -- cost centre info -> Module -> Maybe String -- Just m ==> we have flag: -main-is Foo.baz -> ForeignStubs -> [Module] -> Code -mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods +mkModuleInit dflags way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mods = do { -- Allocate the static boolean that records if this @@ -184,31 +183,31 @@ mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mo ; emitSimpleProc plain_init_lbl jump_to_init -- When compiling the module in which the 'main' function lives, - -- (that is, Module.moduleName this_mod == main_mod_name) + -- (that is, this_mod == main_mod) -- we inject an extra stg_init procedure for stg_init_ZCMain, for the -- RTS to invoke. We must consult the -main-is flag in case the -- user specified a different function to Main.main - ; whenC (Module.moduleName this_mod == main_mod_name) + ; whenC (this_mod == main_mod) (emitSimpleProc plain_main_init_lbl jump_to_init) } where - plain_init_lbl = mkPlainModuleInitLabel this_mod - real_init_lbl = mkModuleInitLabel this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN + plain_init_lbl = mkPlainModuleInitLabel dflags this_mod + real_init_lbl = mkModuleInitLabel dflags this_mod way + plain_main_init_lbl = mkPlainModuleInitLabel dflags rOOT_MAIN jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) wordRep - main_mod_name = case mb_main_mod of - Just mod_name -> mkModuleName mod_name - Nothing -> mAIN_Name + main_mod = case mb_main_mod of + Just mod_name -> mkModule mod_name + Nothing -> mAIN -- Main refers to GHC.TopHandler.runIO, so make sure we call the -- init function for GHC.TopHandler. extra_imported_mods - | Module.moduleName this_mod == main_mod_name = [pREL_TOP_HANDLER] - | otherwise = [] + | this_mod == main_mod = [pREL_TOP_HANDLER] + | otherwise = [] mod_init_code = do { -- Set mod_reg to 1 to record that we've been here @@ -217,18 +216,19 @@ mkModuleInit way cost_centre_info this_mod mb_main_mod foreign_stubs imported_mo -- Now do local stuff ; registerForeignExports foreign_stubs ; initCostCentres cost_centre_info - ; mapCs (registerModuleImport way) (imported_mods++extra_imported_mods) + ; mapCs (registerModuleImport dflags way) + (imported_mods++extra_imported_mods) } ----------------------- -registerModuleImport :: String -> Module -> Code -registerModuleImport way mod +registerModuleImport :: DynFlags -> String -> Module -> Code +registerModuleImport dflags 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 mod way)) ] + , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel dflags mod way)) ] ----------------------- registerForeignExports :: ForeignStubs -> Code @@ -239,7 +239,8 @@ registerForeignExports (ForeignStubs _ _ _ fe_bndrs) where mk_export_register bndr = emitRtsCall SLIT("getStablePtr") - [ (CmmLit (CmmLabel (mkClosureLabel (idName bndr))), PtrHint) ] + [ (CmmLit (CmmLabel (mkLocalClosureLabel (idName bndr))), + PtrHint) ] \end{code} @@ -280,32 +281,32 @@ style, with the increasing static environment being plumbed as a state variable. \begin{code} -cgTopBinding :: (StgBinding,[(Id,[Id])]) -> Code -cgTopBinding (StgNonRec id rhs, srts) +cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> Code +cgTopBinding dflags (StgNonRec id rhs, srts) = do { id' <- maybeExternaliseId id - ; mapM_ (mkSRT [id']) srts + ; mapM_ (mkSRT 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 (StgRec pairs, srts) +cgTopBinding dflags (StgRec pairs, srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs maybeExternaliseId bndrs ; let pairs' = zip bndrs' rhss - ; mapM_ (mkSRT bndrs') srts + ; mapM_ (mkSRT dflags bndrs') srts ; new_binds <- fixC (\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; nopC } -mkSRT :: [Id] -> (Id,[Id]) -> Code -mkSRT these (id,[]) = nopC -mkSRT these (id,ids) +mkSRT :: DynFlags -> [Id] -> (Id,[Id]) -> Code +mkSRT dflags these (id,[]) = nopC +mkSRT dflags these (id,ids) = do { ids <- mapFCs remap ids ; id <- remap id ; emitRODataLits (mkSRTLabel (idName id)) - (map (CmmLabel . mkClosureLabel . idName) ids) + (map (CmmLabel . mkClosureLabel dflags . idName) ids) } where -- Sigh, better map all the ids against the environment in diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs index 289bd07b20..12825fe7b3 100644 --- a/ghc/compiler/compMan/CompManager.lhs +++ b/ghc/compiler/compMan/CompManager.lhs @@ -41,6 +41,8 @@ module CompManager ( cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable) cmSetDFlags, + cmGetDFlags, + cmGetBindings, -- :: CmState -> [TyThing] cmGetPrintUnqual, -- :: CmState -> PrintUnqualified #endif @@ -49,19 +51,21 @@ where #include "HsVersions.h" +import Packages ( isHomeModule ) import DriverPipeline ( CompResult(..), preprocess, compile, link ) import HscMain ( newHscEnv ) import DriverState ( v_Output_file, v_NoHsMain, v_MainModIs ) import DriverPhases import Finder import HscTypes -import PrelNames ( gHC_PRIM_Name ) -import Module ( Module, ModuleName, moduleName, mkModuleName, isHomeModule, - ModuleEnv, lookupModuleEnvByName, mkModuleEnv, moduleEnvElts, - extendModuleEnvList, extendModuleEnv, - moduleNameUserString, +import PrelNames ( gHC_PRIM ) +import Module ( Module, mkModule, + ModuleEnv, lookupModuleEnv, mkModuleEnv, + moduleEnvElts, extendModuleEnvList, extendModuleEnv, + moduleUserString, ModLocation(..) ) import GetImports +import LoadIface ( noIfaceErr ) import UniqFM import Digraph ( SCC(..), stronglyConnComp, flattenSCC, flattenSCCs ) import ErrUtils ( showPass ) @@ -70,7 +74,7 @@ import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Util import Outputable import Panic -import CmdLineOpts ( DynFlags(..), getDynFlags ) +import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt_unset ) import Maybes ( expectJust, orElse, mapCatMaybes ) import DATA_IOREF ( readIORef ) @@ -78,7 +82,7 @@ import DATA_IOREF ( readIORef ) #ifdef GHCI import HscMain ( hscGetInfo, GetInfoResult, hscStmt, hscTcExpr, hscKcType ) import TcRnDriver ( mkExportEnv, getModuleContents ) -import IfaceSyn ( IfaceDecl, IfaceInst ) +import IfaceSyn ( IfaceDecl ) import RdrName ( GlobalRdrEnv, plusGlobalRdrEnv ) import Name ( Name ) import NameEnv @@ -145,7 +149,7 @@ discardCMInfo cm_state type UnlinkedImage = [Linkable] -- the unlinked images (should be a set, really) -findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable +findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable findModuleLinkable_maybe lis mod = case [LM time nm us | LM time nm us <- lis, nm == mod] of [] -> Nothing @@ -177,7 +181,7 @@ cmSetContext cmstate toplevs exports = do hsc_env = cm_hsc cmstate hpt = hsc_HPT hsc_env - export_env <- mkExportEnv hsc_env (map mkModuleName exports) + export_env <- mkExportEnv hsc_env (map mkModule exports) toplev_envs <- mapM (mkTopLevEnv hpt) toplevs let all_env = foldr plusGlobalRdrEnv export_env toplev_envs @@ -187,7 +191,7 @@ cmSetContext cmstate toplevs exports = do mkTopLevEnv :: HomePackageTable -> String -> IO GlobalRdrEnv mkTopLevEnv hpt mod - = case lookupModuleEnvByName hpt (mkModuleName mod) of + = case lookupModuleEnv hpt (mkModule mod) of Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not a home module " ++ mod)) Just details -> case hm_globals details of Nothing -> throwDyn (ProgramError ("mkTopLevEnv: not interpreted " ++ mod)) @@ -199,15 +203,19 @@ cmGetContext CmState{cm_ic=ic} = cmModuleIsInterpreted :: CmState -> String -> IO Bool cmModuleIsInterpreted cmstate str - = case lookupModuleEnvByName (cmHPT cmstate) (mkModuleName str) of + = case lookupModuleEnv (cmHPT cmstate) (mkModule str) of Just details -> return (isJust (hm_globals details)) _not_a_home_module -> return False ----------------------------------------------------------------------------- + cmSetDFlags :: CmState -> DynFlags -> CmState cmSetDFlags cm_state dflags = cm_state { cm_hsc = (cm_hsc cm_state) { hsc_dflags = dflags } } +cmGetDFlags :: CmState -> DynFlags +cmGetDFlags cm_state = hsc_dflags (cm_hsc cm_state) + ----------------------------------------------------------------------------- -- cmInfoThing: convert a String to a TyThing @@ -223,7 +231,7 @@ cmGetInfo cmstate id = hscGetInfo (cm_hsc cmstate) (cm_ic cmstate) id cmBrowseModule :: CmState -> String -> Bool -> IO [IfaceDecl] cmBrowseModule cmstate str exports_only = do { mb_decls <- getModuleContents (cm_hsc cmstate) (cm_ic cmstate) - (mkModuleName str) exports_only + (mkModule str) exports_only ; case mb_decls of Nothing -> return [] -- An error of some kind Just ds -> return ds @@ -241,7 +249,12 @@ data CmRunResult cmRunStmt :: CmState -> String -> IO (CmState, CmRunResult) cmRunStmt cmstate@CmState{ cm_hsc=hsc_env, cm_ic=icontext } expr = do - maybe_stuff <- hscStmt hsc_env icontext expr + -- Turn off -fwarn-unused-bindings when running a statement, to hide + -- warnings about the implicit bindings we introduce. + let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + hsc_env' = hsc_env{ hsc_dflags = dflags' } + + maybe_stuff <- hscStmt hsc_env' icontext expr case maybe_stuff of Nothing -> return (cmstate, CmRunFailed) @@ -423,7 +436,7 @@ cmDepAnal cmstate rootnames hPutStrLn stderr (showSDoc (hcat [ text "Chasing modules from: ", hcat (punctuate comma (map text rootnames))])) - downsweep rootnames (cm_mg cmstate) + downsweep dflags rootnames (cm_mg cmstate) where hsc_env = cm_hsc cmstate dflags = hsc_dflags hsc_env @@ -455,13 +468,13 @@ cmLoadModules cmstate1 mg2unsorted let main_mod = mb_main_mod `orElse` "Main" a_root_is_Main - = any ((==main_mod).moduleNameUserString.modSummaryName) + = any ((==main_mod).moduleUserString.ms_mod) mg2unsorted - let mg2unsorted_names = map modSummaryName mg2unsorted + let mg2unsorted_names = map ms_mod mg2unsorted -- reachable_from follows source as well as normal imports - let reachable_from :: ModuleName -> [ModuleName] + let reachable_from :: Module -> [Module] reachable_from = downwards_closure_of_module mg2unsorted -- should be cycle free; ignores 'import source's @@ -480,8 +493,7 @@ cmLoadModules cmstate1 mg2unsorted -- putStrLn (showSDoc (vcat [ppr valid_old_linkables, ppr new_linkables])) - -- Uniq of ModuleName is the same as Module, fortunately... - let hpt2 = delListFromUFM hpt1 (map linkableModName new_linkables) + let hpt2 = delListFromUFM hpt1 (map linkableModule new_linkables) hsc_env2 = hsc_env { hsc_HPT = hpt2 } -- When (verb >= 2) $ @@ -505,12 +517,12 @@ cmLoadModules cmstate1 mg2unsorted = concatMap (findInSummaries mg2unsorted) stable_mods stable_linkables - = filter (\m -> linkableModName m `elem` stable_mods) + = filter (\m -> linkableModule m `elem` stable_mods) valid_old_linkables when (verb >= 2) $ hPutStrLn stderr (showSDoc (text "Stable modules:" - <+> sep (map (text.moduleNameUserString) stable_mods))) + <+> sep (map (text.moduleUserString) stable_mods))) -- Unload any modules which are going to be re-linked this -- time around. @@ -525,7 +537,7 @@ cmLoadModules cmstate1 mg2unsorted -- done before the upsweep is abandoned. let upsweep_these = filter (\scc -> any (`notElem` stable_mods) - (map modSummaryName (flattenSCC scc))) + (map ms_mod (flattenSCC scc))) mg2 --hPutStrLn stderr "after tsort:\n" @@ -540,7 +552,7 @@ cmLoadModules cmstate1 mg2unsorted -- turn. Final result is version 3 of everything. -- clean up between compilations - let cleanup = cleanTempFilesExcept verb + let cleanup = cleanTempFilesExcept dflags (ppFilesFromSummaries (flattenSCCs mg2)) (upsweep_ok, hsc_env3, modsUpswept) @@ -570,7 +582,7 @@ cmLoadModules cmstate1 mg2unsorted hPutStrLn stderr "Upsweep completely successful." -- clean up after ourselves - cleanTempFilesExcept verb (ppFilesFromSummaries modsDone) + cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) ofile <- readIORef v_Output_file no_hs_main <- readIORef v_NoHsMain @@ -600,19 +612,19 @@ cmLoadModules cmstate1 mg2unsorted hPutStrLn stderr "Upsweep partially successful." let modsDone_names - = map modSummaryName modsDone + = map ms_mod modsDone let mods_to_zap_names = findPartiallyCompletedCycles modsDone_names mg2_with_srcimps let mods_to_keep - = filter ((`notElem` mods_to_zap_names).modSummaryName) + = filter ((`notElem` mods_to_zap_names).ms_mod) modsDone - let hpt4 = retainInTopLevelEnvs (map modSummaryName mods_to_keep) + let hpt4 = retainInTopLevelEnvs (map ms_mod mods_to_keep) (hsc_HPT hsc_env3) -- Clean up after ourselves - cleanTempFilesExcept verb (ppFilesFromSummaries mods_to_keep) + cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) -- Link everything together linkresult <- link ghci_mode dflags False hpt4 @@ -633,7 +645,7 @@ cmLoadFinish ok Failed cmstate -- newly loaded module, or the Prelude if none were loaded. cmLoadFinish ok Succeeded cmstate = do let new_cmstate = cmstate { cm_ic = emptyInteractiveContext } - mods_loaded = map (moduleNameUserString.modSummaryName) + mods_loaded = map (moduleUserString.ms_mod) (cm_mg cmstate) return (new_cmstate, ok, mods_loaded) @@ -669,7 +681,7 @@ ppFilesFromSummaries summaries getValidLinkables :: GhciMode -> [Linkable] -- old linkables - -> [ModuleName] -- all home modules + -> [Module] -- all home modules -> [SCC ModSummary] -- all modules in the program, dependency order -> IO ( [Linkable], -- still-valid linkables [Linkable] -- new linkables we just found @@ -689,7 +701,7 @@ getValidLinkables mode old_linkables all_home_mods module_graph = do getValidLinkablesSCC mode old_linkables all_home_mods new_linkables scc0 = let scc = flattenSCC scc0 - scc_names = map modSummaryName scc + scc_names = map ms_mod scc home_module m = m `elem` all_home_mods && m `notElem` scc_names scc_allhomeimps = nub (filter home_module (concatMap ms_imps scc)) -- NB. ms_imps, not ms_allimps above. We don't want to @@ -729,7 +741,7 @@ getValidLinkable old_linkables objects_allowed new_linkables summary -- have a .o-file linkable. We only permit it if all the -- modules it depends on also have .o files; a .o file can't -- link to a bytecode module - = do let mod_name = modSummaryName summary + = do let mod_name = ms_mod summary maybe_disk_linkable <- if (not objects_allowed) @@ -795,21 +807,21 @@ hptLinkables hpt = map hm_linkable (moduleEnvElts hpt) -- * has an interface in the HPT (interactive mode only) preUpsweep :: [Linkable] -- new valid linkables - -> [ModuleName] -- names of all mods encountered in downsweep - -> [ModuleName] -- accumulating stable modules + -> [Module] -- names of all mods encountered in downsweep + -> [Module] -- accumulating stable modules -> [SCC ModSummary] -- scc-ified mod graph, including src imps - -> IO [ModuleName] -- stable modules + -> IO [Module] -- stable modules preUpsweep valid_lis all_home_mods stable [] = return stable preUpsweep valid_lis all_home_mods stable (scc0:sccs) = do let scc = flattenSCC scc0 - scc_allhomeimps :: [ModuleName] + scc_allhomeimps :: [Module] scc_allhomeimps = nub (filter (`elem` all_home_mods) (concatMap ms_allimps scc)) all_imports_in_scc_or_stable = all in_stable_or_scc scc_allhomeimps scc_names - = map modSummaryName scc + = map ms_mod scc in_stable_or_scc m = m `elem` scc_names || m `elem` stable @@ -817,7 +829,7 @@ preUpsweep valid_lis all_home_mods stable (scc0:sccs) -- have a valid linkable (see getValidLinkables above). has_valid_linkable new_summary = isJust (findModuleLinkable_maybe valid_lis modname) - where modname = modSummaryName new_summary + where modname = ms_mod new_summary scc_is_stable = all_imports_in_scc_or_stable && all has_valid_linkable scc @@ -830,9 +842,9 @@ preUpsweep valid_lis all_home_mods stable (scc0:sccs) -- Helper for preUpsweep. Assuming that new_summary's imports are all -- stable (in the sense of preUpsweep), determine if new_summary is itself -- stable, and, if so, in batch mode, return its linkable. -findInSummaries :: [ModSummary] -> ModuleName -> [ModSummary] +findInSummaries :: [ModSummary] -> Module -> [ModSummary] findInSummaries old_summaries mod_name - = [s | s <- old_summaries, modSummaryName s == mod_name] + = [s | s <- old_summaries, ms_mod s == mod_name] findModInSummaries :: [ModSummary] -> Module -> Maybe ModSummary findModInSummaries old_summaries mod @@ -842,14 +854,14 @@ findModInSummaries old_summaries mod -- Return (names of) all those in modsDone who are part of a cycle -- as defined by theGraph. -findPartiallyCompletedCycles :: [ModuleName] -> [SCC ModSummary] -> [ModuleName] +findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] findPartiallyCompletedCycles modsDone theGraph = chew theGraph where chew [] = [] chew ((AcyclicSCC v):rest) = chew rest -- acyclic? not interesting. chew ((CyclicSCC vs):rest) - = let names_in_this_cycle = nub (map modSummaryName vs) + = let names_in_this_cycle = nub (map ms_mod vs) mods_in_this_cycle = nub ([done | done <- modsDone, done `elem` names_in_this_cycle]) @@ -865,7 +877,7 @@ findPartiallyCompletedCycles modsDone theGraph -- There better had not be any cyclic groups here -- we check for them. upsweep_mods :: HscEnv -- Includes up-to-date HPT -> [Linkable] -- Valid linkables - -> (ModuleName -> [ModuleName]) -- to construct downward closures + -> (Module -> [Module]) -- to construct downward closures -> IO () -- how to clean up unwanted tmp files -> [SCC ModSummary] -- mods to do (the worklist) -- ...... RETURNING ...... @@ -880,16 +892,16 @@ upsweep_mods hsc_env oldUI reachable_from cleanup upsweep_mods hsc_env oldUI reachable_from cleanup ((CyclicSCC ms):_) = do hPutStrLn stderr ("Module imports form a cycle for modules:\n\t" ++ - unwords (map (moduleNameUserString.modSummaryName) ms)) + unwords (map (moduleUserString.ms_mod) ms)) return (Failed, hsc_env, []) upsweep_mods hsc_env oldUI reachable_from cleanup ((AcyclicSCC mod):mods) = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleNameUserString.moduleName.mi_module.hm_iface) (eltsUFM (hsc_HPT hsc_env))) + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) (eltsUFM (hsc_HPT hsc_env))) (ok_flag, hsc_env1) <- upsweep_mod hsc_env oldUI mod - (reachable_from (modSummaryName mod)) + (reachable_from (ms_mod mod)) cleanup -- Remove unwanted tmp files between compilations @@ -906,7 +918,7 @@ upsweep_mods hsc_env oldUI reachable_from cleanup upsweep_mod :: HscEnv -> UnlinkedImage -> ModSummary - -> [ModuleName] + -> [Module] -> IO (SuccessFlag, HscEnv) -- With updated HPT @@ -914,17 +926,16 @@ upsweep_mod hsc_env oldUI summary1 reachable_inc_me = do let this_mod = ms_mod summary1 location = ms_location summary1 - mod_name = moduleName this_mod hpt1 = hsc_HPT hsc_env - let mb_old_iface = case lookupModuleEnvByName hpt1 mod_name of + let mb_old_iface = case lookupModuleEnv hpt1 this_mod of Just mod_info -> Just (hm_iface mod_info) Nothing -> Nothing - let maybe_old_linkable = findModuleLinkable_maybe oldUI mod_name + let maybe_old_linkable = findModuleLinkable_maybe oldUI this_mod source_unchanged = isJust maybe_old_linkable - reachable_only = filter (/= mod_name) reachable_inc_me + reachable_only = filter (/= this_mod) reachable_inc_me -- In interactive mode, all home modules below us *must* have an -- interface in the HPT. We never demand-load home interfaces in @@ -964,7 +975,7 @@ upsweep_mod hsc_env oldUI summary1 reachable_inc_me CompErrs -> return (Failed, hsc_env) -- Filter modules in the HPT -retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs :: [Module] -> HomePackageTable -> HomePackageTable retainInTopLevelEnvs keep_these hpt = listToUFM (concatMap (maybeLookupUFM hpt) keep_these) where @@ -973,13 +984,13 @@ retainInTopLevelEnvs keep_these hpt Just val -> [(u, val)] -- Needed to clean up HPT so that we don't get duplicates in inst env -downwards_closure_of_module :: [ModSummary] -> ModuleName -> [ModuleName] +downwards_closure_of_module :: [ModSummary] -> Module -> [Module] downwards_closure_of_module summaries root - = let toEdge :: ModSummary -> (ModuleName,[ModuleName]) - toEdge summ = (modSummaryName summ, + = let toEdge :: ModSummary -> (Module,[Module]) + toEdge summ = (ms_mod summ, filter (`elem` all_mods) (ms_allimps summ)) - all_mods = map modSummaryName summaries + all_mods = map ms_mod summaries res = simple_transitive_closure (map toEdge summaries) [root] in @@ -1003,13 +1014,13 @@ simple_transitive_closure graph set topological_sort :: Bool -> [ModSummary] -> [SCC ModSummary] topological_sort include_source_imports summaries = let - toEdge :: ModSummary -> (ModSummary,ModuleName,[ModuleName]) + toEdge :: ModSummary -> (ModSummary,Module,[Module]) toEdge summ - = (summ, modSummaryName summ, + = (summ, ms_mod summ, (if include_source_imports then ms_srcimps summ else []) ++ ms_imps summ) - mash_edge :: (ModSummary,ModuleName,[ModuleName]) -> (ModSummary,Int,[Int]) + mash_edge :: (ModSummary,Module,[Module]) -> (ModSummary,Int,[Int]) mash_edge (summ, m, m_imports) = case lookup m key_map of Nothing -> panic "reverse_topological_sort" @@ -1018,7 +1029,7 @@ topological_sort include_source_imports summaries mapCatMaybes (flip lookup key_map) m_imports) edges = map toEdge summaries - key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(ModuleName,Int)] + key_map = zip [nm | (s,nm,imps) <- edges] [1 ..] :: [(Module,Int)] scc_input = map mash_edge edges sccs = stronglyConnComp scc_input in @@ -1036,15 +1047,16 @@ topological_sort include_source_imports summaries -- cache to avoid recalculating a module summary if the source is -- unchanged. -downsweep :: [FilePath] -> [ModSummary] -> IO [ModSummary] -downsweep roots old_summaries +downsweep :: DynFlags -> [FilePath] -> [ModSummary] -> IO [ModSummary] +downsweep dflags roots old_summaries = do rootSummaries <- mapM getRootSummary roots checkDuplicates rootSummaries all_summaries <- loop (concat (map (\ m -> zip (repeat (fromMaybe "<unknown>" (ml_hs_file (ms_location m)))) (ms_imps m)) rootSummaries)) (mkModuleEnv [ (mod, s) | s <- rootSummaries, - let mod = ms_mod s, isHomeModule mod + let mod = ms_mod s, + isHomeModule dflags mod ]) return all_summaries where @@ -1052,14 +1064,14 @@ downsweep roots old_summaries getRootSummary file | isHaskellSrcFilename file = do exists <- doesFileExist file - if exists then summariseFile file else do + if exists then summariseFile dflags file else do throwDyn (CmdLineError ("can't find file `" ++ file ++ "'")) | otherwise = do exists <- doesFileExist hs_file - if exists then summariseFile hs_file else do + if exists then summariseFile dflags hs_file else do exists <- doesFileExist lhs_file - if exists then summariseFile lhs_file else do - let mod_name = mkModuleName file + if exists then summariseFile dflags lhs_file else do + let mod_name = mkModule file maybe_summary <- getSummary (file, mod_name) case maybe_summary of Nothing -> packageModErr mod_name @@ -1084,20 +1096,18 @@ downsweep roots old_summaries [ fromJust (ml_hs_file (ms_location summ')) | summ' <- summaries, ms_mod summ' == modl ] - getSummary :: (FilePath,ModuleName) -> IO (Maybe ModSummary) - getSummary (currentMod,nm) - = do found <- findModule nm + getSummary :: (FilePath,Module) -> IO (Maybe ModSummary) + getSummary (currentMod,mod) + = do found <- findModule dflags mod True{-explicit-} case found of - Right (mod, location) -> do + Found location pkg -> do let old_summary = findModInSummaries old_summaries mod - summarise mod location old_summary + summarise dflags mod location old_summary - Left files -> do - dflags <- getDynFlags - throwDyn (noModError dflags currentMod nm files) + err -> throwDyn (noModError dflags currentMod mod err) -- loop invariant: env doesn't contain package modules - loop :: [(FilePath,ModuleName)] -> ModuleEnv ModSummary -> IO [ModSummary] + loop :: [(FilePath,Module)] -> ModuleEnv ModSummary -> IO [ModSummary] loop [] env = return (moduleEnvElts env) loop imps env = do -- imports for modules we don't already have @@ -1116,16 +1126,8 @@ downsweep roots old_summaries [ (ms_mod s, s) | s <- new_home_summaries ]) -- ToDo: we don't have a proper line number for this error -noModError dflags loc mod_nm files = ProgramError (showSDoc ( - hang (text loc <> colon) 4 $ - (text "Can't find module" <+> quotes (ppr mod_nm) $$ extra) - )) - where - extra - | verbosity dflags < 3 = - text "(use -v to see a list of the files searched for)" - | otherwise = - hang (ptext SLIT("locations searched:")) 4 (vcat (map text files)) +noModError dflags loc mod_nm err + = ProgramError (showSDoc (noIfaceErr dflags mod_nm err)) ----------------------------------------------------------------------------- -- Summarising modules @@ -1140,19 +1142,19 @@ noModError dflags loc mod_nm files = ProgramError (showSDoc ( -- a summary. The finder is used to locate the file in which the module -- resides. -summariseFile :: FilePath -> IO ModSummary -summariseFile file - = do hspp_fn <- preprocess file - (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn +summariseFile :: DynFlags -> FilePath -> IO ModSummary +summariseFile dflags file + = do hspp_fn <- preprocess dflags file + (srcimps,imps,mod) <- getImportsFromFile hspp_fn let -- GHC.Prim doesn't exist physically, so don't go looking for it. - the_imps = filter (/= gHC_PRIM_Name) imps + the_imps = filter (/= gHC_PRIM) imps - (mod, location) <- mkHomeModLocation mod_name file + location <- mkHomeModLocation mod file src_timestamp <- case ml_hs_file location of - Nothing -> noHsFileErr mod_name + Nothing -> noHsFileErr mod Just src_fn -> getModificationTime src_fn return (ModSummary { ms_mod = mod, @@ -1161,10 +1163,10 @@ summariseFile file ms_hs_date = src_timestamp }) -- Summarise a module, and pick up source and timestamp. -summarise :: Module -> ModLocation -> Maybe ModSummary +summarise :: DynFlags -> Module -> ModLocation -> Maybe ModSummary -> IO (Maybe ModSummary) -summarise mod location old_summary - | not (isHomeModule mod) = return Nothing +summarise dflags mod location old_summary + | not (isHomeModule dflags mod) = return Nothing | otherwise = do let hs_fn = expectJust "summarise" (ml_hs_file location) @@ -1179,17 +1181,17 @@ summarise mod location old_summary Just s | ms_hs_date s == src_timestamp -> return (Just s); _ -> do - hspp_fn <- preprocess hs_fn + hspp_fn <- preprocess dflags hs_fn (srcimps,imps,mod_name) <- getImportsFromFile hspp_fn let -- GHC.Prim doesn't exist physically, so don't go looking for it. - the_imps = filter (/= gHC_PRIM_Name) imps + the_imps = filter (/= gHC_PRIM) imps - when (mod_name /= moduleName mod) $ + when (mod_name /= mod) $ throwDyn (ProgramError (showSDoc (text hs_fn <> text ": file name does not match module name" - <+> quotes (ppr (moduleName mod))))) + <+> quotes (ppr mod)))) return (Just (ModSummary mod location{ml_hspp_file=Just hspp_fn} srcimps the_imps src_timestamp)) @@ -1237,8 +1239,8 @@ data ModSummary = ModSummary { ms_mod :: Module, -- name, package ms_location :: ModLocation, -- location - ms_srcimps :: [ModuleName], -- source imports - ms_imps :: [ModuleName], -- non-source imports + ms_srcimps :: [Module], -- source imports + ms_imps :: [Module], -- non-source imports ms_hs_date :: ClockTime -- timestamp of summarised file } @@ -1253,7 +1255,4 @@ instance Outputable ModSummary where ] ms_allimps ms = ms_srcimps ms ++ ms_imps ms - -modSummaryName :: ModSummary -> ModuleName -modSummaryName = moduleName . ms_mod \end{code} diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 440365d7d3..270d44de15 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -43,7 +43,9 @@ import CoreSyn import PprCore ( pprCoreExpr ) import Var ( Var, isId, isTyVar ) import VarEnv -import Name ( hashName, isDllName ) +import Name ( hashName ) +import Packages ( isDllName ) +import CmdLineOpts ( DynFlags ) import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit, Literal( MachLabel ) ) import DataCon ( DataCon, dataConRepArity, dataConArgTys, @@ -1171,7 +1173,7 @@ If this happens we simply make the RHS into an updatable thunk, and 'exectute' it rather than allocating it statically. \begin{code} -rhsIsStatic :: CoreExpr -> Bool +rhsIsStatic :: DynFlags -> 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. @@ -1230,33 +1232,33 @@ rhsIsStatic :: CoreExpr -> Bool -- When opt_RuntimeTypes is on, we keep type lambdas and treat -- them as making the RHS re-entrant (non-updatable). -rhsIsStatic rhs = is_static False rhs - -is_static :: Bool -- True <=> in a constructor argument; must be atomic - -> CoreExpr -> Bool - -is_static False (Lam b e) = isRuntimeVar b || is_static False e - -is_static in_arg (Note (SCC _) e) = False -is_static in_arg (Note _ e) = is_static in_arg e - -is_static in_arg (Lit lit) - = case lit of - MachLabel _ _ -> False - other -> True - -- A MachLabel (foreign import "&foo") in an argument - -- prevents a constructor application from being static. The - -- reason is that it might give rise to unresolvable symbols - -- in the object file: under Linux, references to "weak" - -- symbols from the data segment give rise to "unresolvable - -- relocation" errors at link time This might be due to a bug - -- in the linker, but we'll work around it here anyway. - -- SDM 24/2/2004 - -is_static in_arg other_expr = go other_expr 0 +rhsIsStatic dflags rhs = is_static False rhs where + is_static :: Bool -- True <=> in a constructor argument; must be atomic + -> CoreExpr -> Bool + + is_static False (Lam b e) = isRuntimeVar b || is_static False e + + is_static in_arg (Note (SCC _) e) = False + is_static in_arg (Note _ e) = is_static in_arg e + + is_static in_arg (Lit lit) + = case lit of + MachLabel _ _ -> False + other -> True + -- A MachLabel (foreign import "&foo") in an argument + -- prevents a constructor application from being static. The + -- reason is that it might give rise to unresolvable symbols + -- in the object file: under Linux, references to "weak" + -- symbols from the data segment give rise to "unresolvable + -- relocation" errors at link time This might be due to a bug + -- in the linker, but we'll work around it here anyway. + -- SDM 24/2/2004 + + is_static in_arg other_expr = go other_expr 0 + where go (Var f) n_val_args - | not (isDllName (idName f)) + | not (isDllName dflags (idName f)) = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) -- A naked un-applied variable is *not* deemed a static RHS diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index da88848ae3..d148b2baaf 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -232,7 +232,7 @@ make_var_id :: Name -> C.Id make_var_id = make_id True make_mid :: Module -> C.Id -make_mid = moduleNameString . moduleName +make_mid = moduleString make_qid :: Bool -> Name -> C.Qual C.Id make_qid is_var n = (mname,make_id is_var n) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index e7ae7ee993..39f3978d02 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -8,7 +8,7 @@ module Desugar ( deSugar, deSugarExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn ) +import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt, opt_SccProfilingOn ) import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..), Dependencies(..), TypeEnv, IsBootInterface, unQualInScope ) import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, @@ -26,7 +26,7 @@ import DsBinds ( dsHsBinds, AutoScc(..) ) import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. -import Module ( Module, ModuleName, moduleEnvElts, delModuleEnv, moduleNameFS ) +import Module ( Module, moduleEnvElts, delModuleEnv, moduleFS ) import Id ( Id ) import RdrName ( GlobalRdrEnv ) import NameSet @@ -35,7 +35,7 @@ import VarSet import Bag ( Bag, isEmptyBag, mapBag, emptyBag, bagToList ) import CoreLint ( showPass, endPass ) import CoreFVs ( ruleRhsFreeVars ) -import Packages ( thPackage ) +import Packages ( PackageState(thPackageId) ) import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, mkWarnMsg, errorsFound, WarnMsg ) import ListSetOps ( insertList ) @@ -113,8 +113,11 @@ deSugar hsc_env ; dfun_uses <- readIORef dfun_uses_var -- What dfuns are used ; th_used <- readIORef th_var -- Whether TH is used ; let used_names = allUses dus `unionNameSets` dfun_uses - pkgs | th_used = insertList thPackage (imp_dep_pkgs imports) - | otherwise = imp_dep_pkgs imports + thPackage = thPackageId (pkgState dflags) + pkgs | Just th_id <- thPackage, th_used + = insertList th_id (imp_dep_pkgs imports) + | otherwise + = imp_dep_pkgs imports dep_mods = moduleEnvElts (delModuleEnv (imp_dep_mods imports) mod) -- M.hi-boot can be in the imp_dep_mods, but we must remove @@ -129,11 +132,11 @@ deSugar hsc_env ; usages <- mkUsageInfo hsc_env dir_imp_mods dep_mods used_names ; let - -- ModuleNames don't compare lexicographically usually, + -- Modules don't compare lexicographically usually, -- but we want them to do so here. - le_mod :: ModuleName -> ModuleName -> Bool - le_mod m1 m2 = moduleNameFS m1 <= moduleNameFS m2 - le_dep_mod :: (ModuleName, IsBootInterface) -> (ModuleName, IsBootInterface) -> Bool + 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 deps = Deps { dep_mods = sortLe le_dep_mod dep_mods, diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index 92918a2f43..34eb1aedf6 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -37,7 +37,7 @@ import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- ws previously used in this file. import qualified OccName -import Module ( Module, mkModule, mkModuleName, moduleUserString ) +import Module ( Module, mkModule, moduleUserString ) import Id ( Id, mkLocalId ) import OccName ( mkOccFS ) import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule, @@ -53,7 +53,6 @@ import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan ) import Maybe ( catMaybes ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) ) import BasicTypes ( isBoxed ) -import Packages ( thPackage ) import Outputable import Bag ( bagToList ) import FastString ( unpackFS ) @@ -1388,13 +1387,9 @@ templateHaskellNames = [ typeTyConName, matchTyConName, clauseTyConName, patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName] -tH_SYN_Name = mkModuleName "Language.Haskell.TH.Syntax" -tH_LIB_Name = mkModuleName "Language.Haskell.TH.Lib" - thSyn :: Module --- NB: the TH.Syntax module comes from the "template-haskell" package -thSyn = mkModule thPackage tH_SYN_Name -thLib = mkModule thPackage tH_LIB_Name +thSyn = mkModule "Language.Haskell.TH.Syntax" +thLib = mkModule "Language.Haskell.TH.Lib" mk_known_key_name mod space str uniq = mkExternalName uniq mod (mkOccFS space str) diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 5660d6641e..719714e3da 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.179 2004/11/12 15:51:37 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.180 2004/11/26 16:20:36 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -16,9 +16,9 @@ module InteractiveUI ( #include "HsVersions.h" import CompManager -import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, +import HscTypes ( HomeModInfo(hm_linkable), HomePackageTable, isObjectLinkable, GhciMode(..) ) -import IfaceSyn ( IfaceType, IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..), +import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..), IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart ) import FunDeps ( pprFundeps ) import DriverFlags @@ -27,14 +27,11 @@ import DriverUtil ( remove_spaces ) import Linker ( showLinkerState, linkPackages ) import Util import Module ( showModMsg, lookupModuleEnv ) -import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName, - NamedThing(..) ) +import Name ( Name, NamedThing(..) ) import OccName ( OccName, isSymOcc, occNameUserString ) -import BasicTypes ( StrictnessMark(..), Fixity, defaultFixity, SuccessFlag(..) ) -import Packages +import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) ) import Outputable -import CmdLineOpts ( DynFlag(..), DynFlags(..), getDynFlags, saveDynFlags, - restoreDynFlags, dopt_unset ) +import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt_unset ) import Panic hiding ( showException ) import Config import SrcLoc ( SrcLoc, isGoodSrcLoc ) @@ -154,9 +151,8 @@ helpText = " (eg. -v2, -fglasgow-exts, etc.)\n" -interactiveUI :: [FilePath] -> Maybe String -> IO () -interactiveUI srcs maybe_expr = do - dflags <- getDynFlags +interactiveUI :: DynFlags -> [FilePath] -> Maybe String -> IO () +interactiveUI dflags srcs maybe_expr = do cmstate <- cmInit Interactive dflags; @@ -391,12 +387,10 @@ runStmt stmt | null (filter (not.isSpace) stmt) = return [] | otherwise = do st <- getGHCiState - dflags <- io getDynFlags - let cm_state' = cmSetDFlags (cmstate st) - (dopt_unset dflags Opt_WarnUnusedBinds) + cmstate <- getCmState (new_cmstate, result) <- io $ withProgName (progname st) $ withArgs (args st) $ - cmRunStmt cm_state' stmt + cmRunStmt cmstate stmt setGHCiState st{cmstate = new_cmstate} case result of CmRunFailed -> return [] @@ -617,7 +611,7 @@ addModule files = do (cmstate1, ok, mods) <- io (cmLoadModules (cmstate state) graph) setGHCiState state{ cmstate = cmstate1, targets = new_targets } setContextAfterLoad mods - dflags <- io getDynFlags + dflags <- getDynFlags modulesLoadedMsg ok mods dflags changeDirectory :: String -> GHCi () @@ -697,7 +691,7 @@ loadModule' files = do setGHCiState state{ cmstate = cmstate2, targets = files } setContextAfterLoad mods - dflags <- io (getDynFlags) + dflags <- getDynFlags modulesLoadedMsg ok mods dflags @@ -716,7 +710,7 @@ reloadModule "" = do <- io (cmLoadModules (cmstate state) graph) setGHCiState state{ cmstate=cmstate1 } setContextAfterLoad mods - dflags <- io getDynFlags + dflags <- getDynFlags modulesLoadedMsg ok mods dflags reloadModule _ = noArgs ":reload" @@ -894,26 +888,21 @@ setOptions wds = mapM_ setOpt plus_opts -- now, the GHC flags - pkgs_before <- io (readIORef v_ExplicitPackages) - leftovers <- io (processArgs static_flags minus_opts []) - pkgs_after <- io (readIORef v_ExplicitPackages) - - -- update things if the users wants more packages - let new_packages = pkgs_after \\ pkgs_before - when (not (null new_packages)) $ - newPackages new_packages - - -- don't forget about the extra command-line flags from the - -- extra_ghc_opts fields in the new packages - new_package_details <- io (getPackageDetails new_packages) + leftovers <- io $ processStaticFlags minus_opts -- then, dynamic flags - io $ do - restoreDynFlags - leftovers <- processArgs dynamic_flags leftovers [] - saveDynFlags - - if (not (null leftovers)) + dflags <- getDynFlags + (dflags',leftovers) <- io $ processDynamicFlags leftovers dflags + setDynFlags dflags' + + -- update things if the users wants more packages +{- TODO: + let new_packages = pkgs_after \\ pkgs_before + when (not (null new_packages)) $ + newPackages new_packages +-} + + if (not (null leftovers)) then throwDyn (CmdLineError ("unrecognised flags: " ++ unwords leftovers)) else return () @@ -968,7 +957,7 @@ newPackages new_pkgs = do -- The new packages are already in v_Packages state <- getGHCiState cmstate1 <- io (cmUnload (cmstate state)) setGHCiState state{ cmstate = cmstate1, targets = [] } - dflags <- io getDynFlags + dflags <- getDynFlags io (linkPackages dflags new_pkgs) setContextAfterLoad [] @@ -1048,6 +1037,10 @@ setGHCiState s = GHCi $ \r -> writeIORef r s getCmState = getGHCiState >>= return . cmstate setCmState cms = do s <- getGHCiState; setGHCiState s{cmstate=cms} +getDynFlags = getCmState >>= return . cmGetDFlags + +setDynFlags dflags = do s <- getCmState; setCmState (cmSetDFlags s dflags) + isOptionSet :: GHCiOption -> GHCi Bool isOptionSet opt = do st <- getGHCiState diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs index 1ac21e3363..5b59b9d6fd 100644 --- a/ghc/compiler/ghci/Linker.lhs +++ b/ghc/compiler/ghci/Linker.lhs @@ -29,20 +29,20 @@ import ByteCodeItbls ( ItblEnv ) import ByteCodeAsm ( CompiledByteCode(..), bcoFreeNames, UnlinkedBCO(..)) import Packages -import DriverState ( v_Library_paths, v_Opt_l, v_Ld_inputs, getStaticOpts, v_ExplicitPackages ) +import DriverState ( v_Library_paths, v_Opt_l, v_Ld_inputs, getStaticOpts ) import DriverPhases ( isObjectFilename, isDynLibFilename ) import DriverUtil ( getFileSuffix ) #ifdef darwin_TARGET_OS import DriverState ( v_Cmdline_frameworks, v_Framework_paths ) #endif -import Finder ( findModule, findLinkable ) +import Finder ( findModule, findLinkable, FindResult(..) ) import HscTypes -import Name ( Name, nameModule, nameModuleName, isExternalName, isWiredInName ) +import Name ( Name, nameModule, isExternalName, isWiredInName ) import NameEnv import NameSet ( nameSetToList ) import Module import ListSetOps ( minusList ) -import CmdLineOpts ( DynFlags(verbosity), getDynFlags ) +import CmdLineOpts ( DynFlags(..) ) import BasicTypes ( SuccessFlag(..), succeeded, failed ) import Outputable import Panic ( GhcException(..) ) @@ -106,22 +106,25 @@ data PersistentLinkerState -- The currently-loaded packages; always object code -- Held, as usual, in dependency order; though I am not sure if -- that is really important - pkgs_loaded :: [PackageName] + pkgs_loaded :: [PackageId] } -emptyPLS :: PersistentLinkerState -emptyPLS = PersistentLinkerState { closure_env = emptyNameEnv, - itbl_env = emptyNameEnv, - pkgs_loaded = init_pkgs_loaded, - bcos_loaded = [], - objs_loaded = [] } +emptyPLS :: DynFlags -> PersistentLinkerState +emptyPLS dflags = PersistentLinkerState { + closure_env = emptyNameEnv, + itbl_env = emptyNameEnv, + pkgs_loaded = init_pkgs, + bcos_loaded = [], + objs_loaded = [] } + -- Packages that don't need loading, because the compiler + -- shares them with the interpreted program. + -- + -- The linker's symbol table is populated with RTS symbols using an + -- explicit list. See rts/Linker.c for details. + where init_pkgs + | Just rts_id <- rtsPackageId (pkgState dflags) = [rts_id] + | otherwise = [] --- Packages that don't need loading, because the compiler --- shares them with the interpreted program. --- --- The linker's symbol table is populated with RTS symbols using an --- explicit list. See rts/Linker.c for details. -init_pkgs_loaded = [ FSLIT("rts") ] \end{code} \begin{code} @@ -139,12 +142,12 @@ extendLinkEnv new_bindings -- (these are the temporary bindings from the command line). -- Used to filter both the ClosureEnv and ItblEnv -filterNameMap :: [ModuleName] -> NameEnv (Name, a) -> NameEnv (Name, a) +filterNameMap :: [Module] -> NameEnv (Name, a) -> NameEnv (Name, a) filterNameMap mods env = filterNameEnv keep_elt env where keep_elt (n,_) = isExternalName n - && (nameModuleName n `elem` mods) + && (nameModule n `elem` mods) \end{code} @@ -184,28 +187,25 @@ d) Loading any .o/.dll files specified on the command line, e) Loading any MacOS frameworks \begin{code} -initDynLinker :: IO () +initDynLinker :: DynFlags -> IO () -- This function is idempotent; if called more than once, it does nothing -- This is useful in Template Haskell, where we call it before trying to link -initDynLinker +initDynLinker dflags = do { done <- readIORef v_InitLinkerDone ; if done then return () else do { writeIORef v_InitLinkerDone True - ; reallyInitDynLinker } + ; reallyInitDynLinker dflags } } -reallyInitDynLinker - = do { dflags <- getDynFlags - - -- Initialise the linker state - ; writeIORef v_PersistentLinkerState emptyPLS +reallyInitDynLinker dflags + = do { -- Initialise the linker state + ; writeIORef v_PersistentLinkerState (emptyPLS dflags) -- (a) initialise the C dynamic linker ; initObjLinker -- (b) Load packages from the command-line - ; expl <- readIORef v_ExplicitPackages - ; linkPackages dflags expl + ; linkPackages dflags (explicitPackages (pkgState dflags)) -- (c) Link libraries from the command-line ; opt_l <- getStaticOpts v_Opt_l @@ -315,11 +315,12 @@ linkExpr :: HscEnv -> UnlinkedBCO -> IO HValue linkExpr hsc_env root_ul_bco = do { -- Initialise the linker (if it's not been done already) - initDynLinker + let dflags = hsc_dflags hsc_env + ; initDynLinker dflags -- Find what packages and linkables are required ; eps <- readIORef (hsc_EPS hsc_env) - ; (lnks, pkgs) <- getLinkDeps hpt (eps_PIT eps) needed_mods + ; (lnks, pkgs) <- getLinkDeps dflags hpt (eps_PIT eps) needed_mods -- Link the packages and modules required ; linkPackages dflags pkgs @@ -354,12 +355,12 @@ linkExpr hsc_env root_ul_bco dieWith msg = throwDyn (ProgramError (showSDoc msg)) -getLinkDeps :: HomePackageTable -> PackageIfaceTable +getLinkDeps :: DynFlags -> HomePackageTable -> PackageIfaceTable -> [Module] -- If you need these - -> IO ([Linkable], [PackageName]) -- ... then link these first + -> IO ([Linkable], [PackageId]) -- ... then link these first -- Fails with an IO exception if it can't find enough files -getLinkDeps hpt pit mods +getLinkDeps dflags hpt pit mods -- Find all the packages and linkables that a set of modules depends on = do { pls <- readIORef v_PersistentLinkerState ; let { @@ -371,7 +372,7 @@ getLinkDeps hpt pit mods mods_needed = nub (concat mods_s) `minusList` linked_mods ; pkgs_needed = nub (concat pkgs_s) `minusList` pkgs_loaded pls ; - linked_mods = map linkableModName (objs_loaded pls ++ bcos_loaded pls) + linked_mods = map linkableModule (objs_loaded pls ++ bcos_loaded pls) } ; -- 3. For each dependent module, find its linkable @@ -381,14 +382,14 @@ getLinkDeps hpt pit mods return (lnks_needed, pkgs_needed) } where - get_deps :: Module -> ([ModuleName],[PackageName]) + get_deps :: Module -> ([Module],[PackageId]) -- Get the things needed for the specified module -- This is rather similar to the code in RnNames.importsFromImportDecl get_deps mod - | isHomeModule (mi_module iface) - = (moduleName mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) + | ExternalPackage p <- mi_package iface + = ([], p : dep_pkgs deps) | otherwise - = ([], mi_package iface : dep_pkgs deps) + = (mod : [m | (m,_) <- dep_mods deps], dep_pkgs deps) where iface = get_iface mod deps = mi_deps iface @@ -403,22 +404,24 @@ getLinkDeps hpt pit mods -- This one is a build-system bug get_linkable mod_name -- A home-package module - | Just mod_info <- lookupModuleEnvByName hpt mod_name + | Just mod_info <- lookupModuleEnv hpt mod_name = return (hm_linkable mod_info) | otherwise = -- 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 mod_name ; + do { mb_stuff <- findModule dflags mod_name False ; case mb_stuff of { - Left _ -> no_obj mod_name ; - Right (_, loc) -> do { + Found loc _ -> found loc mod_name ; + _ -> no_obj mod_name + }} + found loc mod_name = do { -- ...and then find the linkable for it mb_lnk <- findLinkable mod_name loc ; case mb_lnk of { Nothing -> no_obj mod_name ; Just lnk -> return lnk - }}}} + }} \end{code} @@ -461,7 +464,7 @@ partitionLinkable li other -> [li] -findModuleLinkable_maybe :: [Linkable] -> ModuleName -> Maybe Linkable +findModuleLinkable_maybe :: [Linkable] -> Module -> Maybe Linkable findModuleLinkable_maybe lis mod = case [LM time nm us | LM time nm us <- lis, nm == mod] of [] -> Nothing @@ -470,7 +473,7 @@ findModuleLinkable_maybe lis mod linkableInSet :: Linkable -> [Linkable] -> Bool linkableInSet l objs_loaded = - case findModuleLinkable_maybe objs_loaded (linkableModName l) of + case findModuleLinkable_maybe objs_loaded (linkableModule l) of Nothing -> False Just m -> linkableTime l == linkableTime m \end{code} @@ -642,7 +645,7 @@ unload_wkr dflags linkables pls objs_loaded' <- filterM (maybeUnload objs_to_keep) (objs_loaded pls) bcos_loaded' <- filterM (maybeUnload bcos_to_keep) (bcos_loaded pls) - let bcos_retained = map linkableModName bcos_loaded' + let bcos_retained = map linkableModule bcos_loaded' itbl_env' = filterNameMap bcos_retained (itbl_env pls) closure_env' = filterNameMap bcos_retained (closure_env pls) new_pls = pls { itbl_env = itbl_env', @@ -713,7 +716,7 @@ showLS (DLL nm) = "(dynamic) " ++ nm showLS (DLLPath nm) = "(dynamic) " ++ nm showLS (Framework nm) = "(framework) " ++ nm -linkPackages :: DynFlags -> [PackageName] -> IO () +linkPackages :: DynFlags -> [PackageId] -> IO () -- Link exactly the specified packages, and their dependents -- (unless of course they are already linked) -- The dependents are linked automatically, and it doesn't matter @@ -728,14 +731,14 @@ linkPackages :: DynFlags -> [PackageName] -> IO () linkPackages dflags new_pkgs = do { pls <- readIORef v_PersistentLinkerState - ; pkg_map <- getPackageConfigMap + ; let pkg_map = pkgIdMap (pkgState dflags) ; pkgs' <- link pkg_map (pkgs_loaded pls) new_pkgs ; writeIORef v_PersistentLinkerState (pls { pkgs_loaded = pkgs' }) } where - link :: PackageConfigMap -> [PackageName] -> [PackageName] -> IO [PackageName] + link :: PackageConfigMap -> [PackageId] -> [PackageId] -> IO [PackageId] link pkg_map pkgs new_pkgs = foldM (link_one pkg_map) pkgs new_pkgs @@ -743,15 +746,15 @@ linkPackages dflags new_pkgs | new_pkg `elem` pkgs -- Already linked = return pkgs - | Just pkg_cfg <- lookupPkg pkg_map new_pkg + | Just pkg_cfg <- lookupPackage pkg_map new_pkg = do { -- Link dependents first - pkgs' <- link pkg_map pkgs (packageDependents pkg_cfg) + pkgs' <- link pkg_map pkgs (map mkPackageId (depends pkg_cfg)) -- Now link the package itself ; linkPackage dflags pkg_cfg ; return (new_pkg : pkgs') } | otherwise - = throwDyn (CmdLineError ("unknown package name: " ++ packageNameString new_pkg)) + = throwDyn (CmdLineError ("unknown package: " ++ packageIdString new_pkg)) linkPackage :: DynFlags -> PackageConfig -> IO () diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 7343a8baa4..a57fd76630 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -16,7 +16,7 @@ import Language.Haskell.TH.Syntax as TH import HsSyn as Hs import qualified Class (FunDep) import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName ) -import Module ( ModuleName, mkModuleName ) +import Module ( Module, mkModule ) import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData ) import Name ( mkInternalName ) import qualified OccName @@ -422,8 +422,8 @@ mk_uniq u = mkUniqueGrimily (I# u) mk_occ :: OccName.NameSpace -> TH.OccName -> OccName.OccName mk_occ ns occ = OccName.mkOccFS ns (mkFastString (TH.occString occ)) -mk_mod :: TH.ModName -> ModuleName -mk_mod mod = mkModuleName (TH.modString mod) +mk_mod :: TH.ModName -> Module +mk_mod mod = mkModule (TH.modString mod) mkDynName :: OccName.NameSpace -> TH.OccName -> RdrName -- Parse the string to see if it has a "." in it @@ -440,6 +440,6 @@ mkDynName ns th_occ split occ (c:rev) = split (c:occ) rev mk_occ occ = OccName.mkOccFS ns (mkFastString occ) - mk_mod mod = mkModuleName mod + mk_mod mod = mkModule mod \end{code} diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index f63d86aec2..220afb7499 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -8,7 +8,7 @@ module HsImpExp where #include "HsVersions.h" -import Module ( ModuleName ) +import Module ( Module ) import Outputable import FastString import SrcLoc ( Located(..) ) @@ -26,10 +26,10 @@ One per \tr{import} declaration in a module. type LImportDecl name = Located (ImportDecl name) data ImportDecl name - = ImportDecl (Located ModuleName) -- module name + = ImportDecl (Located Module) -- module name Bool -- True <=> {-# SOURCE #-} import Bool -- True => qualified - (Maybe ModuleName) -- as Module + (Maybe Module) -- as Module (Maybe (Bool, [LIE name])) -- (True => hiding, names) \end{code} @@ -72,7 +72,7 @@ data IE name | IEThingAbs name -- Class/Type (can't tell) | IEThingAll name -- Class/Type plus all methods/constructors | IEThingWith name [name] -- Class/Type plus some methods/constructors - | IEModuleContents ModuleName -- (Export Only) + | IEModuleContents Module -- (Export Only) \end{code} \begin{code} diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index 286c612dfb..0d9f61934c 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -16,7 +16,6 @@ import IfaceSyn import VarEnv import Class ( DefMeth(..) ) import CostCentre -import Module ( moduleName, mkModule ) import DriverState ( v_Build_tag ) import CmdLineOpts ( opt_HiVersion ) import Kind ( Kind(..) ) @@ -95,7 +94,7 @@ instance Binary ModIface where put_ bh (ModIface { mi_module = mod, mi_mod_vers = mod_vers, - mi_package = pkg_name, + mi_package = _, -- we ignore the package on output mi_orphan = orphan, mi_deps = deps, mi_usages = usages, @@ -110,8 +109,7 @@ instance Binary ModIface where put_ bh (show opt_HiVersion) build_tag <- readIORef v_Build_tag put bh build_tag - put_ bh pkg_name - put_ bh (moduleName mod) + put_ bh mod put_ bh mod_vers put_ bh orphan lazyPut bh deps @@ -145,7 +143,6 @@ instance Binary ModIface where "mismatched interface file ways: expected " ++ build_tag ++ ", found " ++ check_way)) - pkg_name <- get bh mod_name <- get bh mod_vers <- get bh @@ -161,12 +158,8 @@ instance Binary ModIface where rules <- {-# SCC "bin_rules" #-} lazyGet bh rule_vers <- get bh return (ModIface { - mi_package = pkg_name, - mi_module = mkModule pkg_name mod_name, - -- We write the module as a ModuleName, becuase whether - -- or not it's a home-package module depends on the importer - -- mkModule reconstructs the Module, by comparing the static - -- opt_InPackage flag with the package name in the interface file + mi_package = ThisPackage, -- to be filled in properly later + mi_module = mod_name, mi_mod_vers = mod_vers, mi_boot = False, -- Binary interfaces are never .hi-boot files! mi_orphan = orphan, diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index 6922ac9a96..d639e96ace 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -29,9 +29,9 @@ import Name ( Name, nameUnique, nameModule, mkExternalName, mkInternalName ) import OccName ( OccName, isTupleOcc_maybe, tcName, dataName, lookupOccEnv, unitOccEnv, extendOccEnv, extendOccEnvList ) -import PrelNames ( gHC_PRIM_Name, pREL_TUP_Name ) -import Module ( Module, ModuleName, moduleName, mkPackageModule, - emptyModuleEnv, lookupModuleEnvByName, extendModuleEnv_C ) +import PrelNames ( gHC_PRIM, pREL_TUP ) +import Module ( Module, mkModule, emptyModuleEnv, + lookupModuleEnv, extendModuleEnv_C ) import UniqSupply ( UniqSupply, splitUniqSupply, uniqFromSupply, uniqsFromSupply ) import FiniteMap ( emptyFM, lookupFM, addToFM ) import BasicTypes ( IPName(..), mapIPName ) @@ -71,7 +71,7 @@ allocateGlobalBinder -> Module -> OccName -> Maybe Name -> SrcLoc -> (NameCache, Name) allocateGlobalBinder name_supply mod occ mb_parent loc - = case lookupOrigNameCache (nsNames name_supply) (moduleName mod) occ of + = case lookupOrigNameCache (nsNames name_supply) mod occ of -- A hit in the cache! We are at the binding site of the name. -- This is the moment when we know the defining Module and SrcLoc -- of the Name, so we set these fields in the Name we return. @@ -126,12 +126,8 @@ newImplicitBinder base_name mk_sys_occ Just parent_name -> parent_name Nothing -> base_name -lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name --- This one starts with a ModuleName, not a Module, because --- we may be simply looking at an occurrence M.x in an interface file. --- We may enounter this well before finding the binding site for M.x --- --- So, even if we get a miss in the original-name cache, we +lookupOrig :: Module -> OccName -> TcRnIf a b Name +-- Even if we get a miss in the original-name cache, we -- make a new External Name. -- We fake up -- Module to AnotherPackage @@ -139,8 +135,8 @@ lookupOrig :: ModuleName -> OccName -> TcRnIf a b Name -- Parent no Nothing -- They'll be overwritten, in due course, by LoadIface.loadDecl. -lookupOrig mod_name occ - = do { -- First ensure that mod_name and occ are evaluated +lookupOrig mod occ + = do { -- First ensure that mod and occ are evaluated -- If not, chaos can ensue: -- we read the name-cache -- then pull on mod (say) @@ -149,20 +145,15 @@ lookupOrig mod_name occ mod `seq` occ `seq` return () ; name_supply <- getNameCache - ; case lookupOrigNameCache (nsNames name_supply) mod_name occ of { + ; case lookupOrigNameCache (nsNames name_supply) mod occ of { Just name -> returnM name ; Nothing -> do { let { (us', us1) = splitUniqSupply (nsUniqs name_supply) ; uniq = uniqFromSupply us1 - ; name = mkExternalName uniq tmp_mod occ Nothing noSrcLoc - ; new_cache = extend_name_cache (nsNames name_supply) tmp_mod occ name + ; name = mkExternalName uniq mod occ Nothing noSrcLoc + ; new_cache = extend_name_cache (nsNames name_supply) mod occ name ; new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} - ; tmp_mod = mkPackageModule mod_name - -- Guess at the package-ness for now, becuase we don't know whether - -- this imported module is from the home package or not. - -- If we ever need it, we'll open its interface, and update the cache - -- with a better name (newGlobalBinder) } ; setNameCache new_name_supply ; return name } @@ -191,10 +182,10 @@ newIPName occ_name_ip Local helper functions (not exported) \begin{code} -lookupOrigNameCache :: OrigNameCache -> ModuleName -> OccName -> Maybe Name -lookupOrigNameCache nc mod_name occ - | mod_name == pREL_TUP_Name || mod_name == gHC_PRIM_Name, -- Boxed tuples from one, - Just tup_info <- isTupleOcc_maybe occ -- unboxed from the other +lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name +lookupOrigNameCache nc mod occ + | mod == pREL_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 Just (mk_tup_name tup_info) @@ -204,8 +195,8 @@ lookupOrigNameCache nc mod_name occ | ns == dataName = dataConName (tupleCon boxity arity) | otherwise = varName (dataConWorkId (tupleCon boxity arity)) -lookupOrigNameCache nc mod_name occ -- The normal case - = case lookupModuleEnvByName nc mod_name of +lookupOrigNameCache nc mod occ -- The normal case + = case lookupModuleEnv nc mod of Nothing -> Nothing Just occ_env -> lookupOccEnv occ_env occ diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index 2edcfc80bb..9fd2d3b701 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -60,9 +60,9 @@ import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) import OccName ( OccName, OccEnv, lookupOccEnv, emptyOccEnv, lookupOccEnv, extendOccEnv, emptyOccEnv, OccSet, unionOccSets, unitOccSet ) -import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModuleName, isExternalName ) +import Name ( Name, NamedThing(..), getOccName, nameOccName, nameModule, isExternalName ) import NameSet ( NameSet, elemNameSet ) -import Module ( ModuleName ) +import Module ( Module ) import CostCentre ( CostCentre, pprCostCentreCore ) import Literal ( Literal ) import ForeignCall ( ForeignCall ) @@ -558,7 +558,7 @@ dfunToIfaceInst dfun_id ifInstHead = toIfaceType (mkLhsNameFn mod) tidy_ty } where dfun_name = idName dfun_id - mod = nameModuleName dfun_name + mod = nameModule dfun_name (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id) head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys)) -- No need to record the instance context; @@ -617,7 +617,7 @@ toIfaceIdInfo ext id_info | otherwise = Just (HsUnfold inline_prag (toIfaceExpr ext rhs)) -------------------------- -coreRuleToIfaceRule :: ModuleName -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule +coreRuleToIfaceRule :: Module -> (Name -> IfaceExtName) -> IdCoreRule -> IfaceRule coreRuleToIfaceRule mod ext (IdCoreRule id _ (BuiltinRule _ _)) = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id))) @@ -701,12 +701,12 @@ toIfaceVar ext v -- mkLhsNameFn ignores versioning info altogether -- Used for the LHS of instance decls and rules, where we -- there's no point in recording version info -mkLhsNameFn :: ModuleName -> Name -> IfaceExtName +mkLhsNameFn :: Module -> Name -> IfaceExtName mkLhsNameFn this_mod name | mod == this_mod = LocalTop occ | otherwise = ExtPkg mod occ where - mod = nameModuleName name + mod = nameModule name occ = nameOccName name \end{code} diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index c3a64a8b59..bb5177892e 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -30,8 +30,8 @@ import TyCon ( TyCon, isTupleTyCon, tyConArity, tupleTyConBoxity ) import Var ( isId, tyVarKind, idType ) import TysWiredIn ( listTyConName, parrTyConName, tupleTyCon, intTyConName, charTyConName, boolTyConName ) import OccName ( OccName ) -import Name ( Name, getName, getOccName, nameModuleName, nameOccName ) -import Module ( ModuleName ) +import Name ( Name, getName, getOccName, nameModule, nameOccName ) +import Module ( Module ) import BasicTypes ( IPName(..), Arity, Version, mapIPName, tupleParens, Boxity ) import Outputable import FastString @@ -46,11 +46,11 @@ import FastString \begin{code} data IfaceExtName - = ExtPkg ModuleName OccName -- From an external package; no version # + = ExtPkg Module OccName -- From an external package; no version # -- Also used for wired-in things regardless -- of whether they are home-pkg or not - | HomePkg ModuleName OccName Version -- From another module in home package; + | HomePkg Module OccName Version -- From another module in home package; -- has version # | LocalTop OccName -- Top-level from the same module as @@ -62,7 +62,7 @@ data IfaceExtName -- LocalTopSub is written into iface files as LocalTop; the parent -- info is only used when computing version information in MkIface -mkIfaceExtName name = ExtPkg (nameModuleName name) (nameOccName name) +mkIfaceExtName name = ExtPkg (nameModule name) (nameOccName name) -- Local helper for wired-in names \end{code} @@ -182,7 +182,7 @@ instance Outputable IfaceExtName where ppr (LocalTop occ) = ppr occ -- Do we want to distinguish these ppr (LocalTopSub occ _) = ppr occ -- from an ordinary occurrence? -pprExt :: ModuleName -> OccName -> SDoc +pprExt :: Module -> OccName -> SDoc pprExt mod occ = getPprStyle $ \ sty -> if unqualStyle sty mod occ then diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index 316aa0ab5f..69896be6db 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -9,49 +9,53 @@ module LoadIface ( loadSrcInterface, loadOrphanModules, loadHiBootInterface, readIface, -- Used when reading the module's old interface predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags, - initExternalPackageState + initExternalPackageState, + noIfaceErr, -- used by CompManager too ) where #include "HsVersions.h" import {-# SOURCE #-} TcIface( tcIfaceDecl ) +import Packages ( PackageState(..), isHomeModule ) import DriverState ( v_GhcMode, isCompManagerMode ) import DriverUtil ( replaceFilenameSuffix ) -import CmdLineOpts ( DynFlags( verbosity ), DynFlag( Opt_IgnoreInterfacePragmas ), - opt_InPackage ) +import CmdLineOpts ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ) ) import Parser ( parseIface ) -import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), IfaceConDecls(..), - IfaceInst(..), IfaceRule(..), IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), - IfaceType(..), IfacePredType(..), IfaceExtName, mkIfaceExtName ) -import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc, lookupOrig ) -import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats, - ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv, - lookupIfaceByModName, emptyPackageIfaceTable, - IsBootInterface, mkIfaceFixCache, Gated, implicitTyThings, - addRulesToPool, addInstsToPool, availNames +import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), + IfaceConDecls(..), IfaceInst(..), IfaceRule(..), + IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), + IfaceType(..), IfacePredType(..), IfaceExtName, + mkIfaceExtName ) +import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc, + lookupOrig ) +import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), + addEpsInStats, ExternalPackageState(..), + PackageTypeEnv, emptyTypeEnv, IfacePackage(..), + lookupIfaceByModule, emptyPackageIfaceTable, + IsBootInterface, mkIfaceFixCache, Gated, + implicitTyThings, addRulesToPool, addInstsToPool, + availNames ) -import BasicTypes ( Version, Fixity(..), FixityDirection(..), isMarkedStrict ) +import BasicTypes ( Version, Fixity(..), FixityDirection(..), + isMarkedStrict ) import TcType ( Type, tcSplitTyConApp_maybe ) import Type ( funTyCon ) import TcRnMonad -import PrelNames ( gHC_PRIM_Name ) +import PrelNames ( gHC_PRIM ) import PrelInfo ( ghcPrimExports ) import PrelRules ( builtinRules ) import Rules ( emptyRuleBase ) import InstEnv ( emptyInstEnv ) import Name ( Name {-instance NamedThing-}, getOccName, - nameModuleName, isInternalName ) + nameModule, isInternalName ) import NameEnv import MkId ( seqId ) -import Packages ( basePackage ) -import Module ( Module, ModuleName, ModLocation(ml_hi_file), - moduleName, isHomeModule, emptyModuleEnv, - extendModuleEnv, lookupModuleEnvByName, lookupModuleEnv, - moduleUserString +import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv, + extendModuleEnv, lookupModuleEnv, moduleUserString ) import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc ) @@ -62,7 +66,7 @@ import Maybes ( isJust, mapCatMaybes ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message, mkLocMessage ) -import Finder ( findModule, findPackageModule, +import Finder ( findModule, findPackageModule, FindResult(..), hiBootExt, hiBootVerExt ) import Lexer import Outputable @@ -85,7 +89,7 @@ import Directory %************************************************************************ \begin{code} -loadSrcInterface :: SDoc -> ModuleName -> IsBootInterface -> RnM ModIface +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 @@ -135,7 +139,7 @@ loadHiBootInterface moduleLoop mod = ptext SLIT("Circular imports: module") <+> quotes (ppr mod) <+> ptext SLIT("depends on itself") -loadOrphanModules :: [ModuleName] -> TcM () +loadOrphanModules :: [Module] -> TcM () loadOrphanModules mods | null mods = returnM () | otherwise = initIfaceTcRn $ @@ -159,9 +163,9 @@ loadOrphanModules mods loadHomeInterface :: SDoc -> Name -> IfM lcl ModIface loadHomeInterface doc name = ASSERT2( not (isInternalName name), ppr name <+> parens doc ) - loadSysInterface doc (nameModuleName name) + loadSysInterface doc (nameModule name) -loadSysInterface :: SDoc -> ModuleName -> IfM lcl ModIface +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 @@ -182,7 +186,7 @@ loadSysInterface doc mod_name %********************************************************* \begin{code} -loadInterface :: SDoc -> ModuleName -> WhereFrom +loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (Either Message ModIface) -- If it can't find a suitable interface file, we -- a) modify the PackageIfaceTable to have an empty entry @@ -201,7 +205,7 @@ loadInterface doc_str mod_name from ; traceIf (text "Considering whether to load" <+> ppr mod_name <+> ppr from) -- Check whether we have the interface already - ; case lookupIfaceByModName hpt (eps_PIT eps) mod_name of { + ; case lookupIfaceByModule hpt (eps_PIT eps) mod_name of { Just iface -> returnM (Right iface) ; -- Already loaded -- The (src_imp == mi_boot iface) test checks that the already-loaded @@ -213,7 +217,7 @@ loadInterface doc_str mod_name from ImportByUser usr_boot -> usr_boot ImportBySystem -> sys_boot - ; mb_dep = lookupModuleEnvByName (eps_is_boot eps) mod_name + ; mb_dep = lookupModuleEnv (eps_is_boot eps) mod_name ; sys_boot = case mb_dep of Just (_, is_boot) -> is_boot Nothing -> False @@ -221,10 +225,13 @@ loadInterface doc_str mod_name from } -- based on the dependencies in directly-imported modules -- READ THE MODULE IN - ; read_result <- findAndReadIface doc_str mod_name hi_boot_file + ; let explicit | ImportByUser _ <- from = True + | otherwise = False + ; read_result <- findAndReadIface explicit doc_str mod_name hi_boot_file + ; dflags <- getDOpts ; case read_result of { Left err -> do - { let fake_iface = emptyModIface opt_InPackage mod_name + { let fake_iface = emptyModIface ThisPackage mod_name ; updateEps_ $ \eps -> eps { eps_PIT = extendModuleEnv (eps_PIT eps) (mi_module fake_iface) fake_iface } @@ -236,14 +243,13 @@ loadInterface doc_str mod_name from -- Found and parsed! Right iface -> - let { mod = mi_module iface - ; mod_name = moduleName mod } in + let { mod = mi_module iface } in -- Sanity check. If we're system-importing a module we know nothing at all -- about, it should be from a different package to this one WARN( case from of { ImportBySystem -> True; other -> False } && not (isJust mb_dep) && - isHomeModule mod, + isHomeModule dflags mod, ppr mod $$ ppr mb_dep $$ ppr (eps_is_boot eps) ) initIfaceLcl mod_name $ do @@ -394,7 +400,7 @@ ifaceDeclSubBndrs _other = [] -- Loading instance decls ----------------------------------------------------- -loadInsts :: ModuleName -> [IfaceInst] -> IfL [(Name, Gated IfaceInst)] +loadInsts :: Module -> [IfaceInst] -> IfL [(Name, Gated IfaceInst)] loadInsts mod decls = mapM (loadInstDecl mod) decls loadInstDecl mod decl@(IfaceInst {ifInstHead = inst_ty}) @@ -435,13 +441,13 @@ loadInstDecl mod decl@(IfaceInst {ifInstHead = inst_ty}) ----------------------------------------------------- loadRules :: Bool -- Don't load pragmas into the decl pool - -> ModuleName + -> Module -> [IfaceRule] -> IfL [Gated IfaceRule] loadRules ignore_prags mod rules | ignore_prags = returnM [] | otherwise = mapM (loadRule mod) rules -loadRule :: ModuleName -> IfaceRule -> IfL (Gated IfaceRule) +loadRule :: Module -> IfaceRule -> IfL (Gated IfaceRule) -- "Gate" the rule simply by a crude notion of the free vars of -- the LHS. It can be crude, because having too few free vars is safe. loadRule mod decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args}) @@ -531,7 +537,8 @@ predInstGates cls tys %********************************************************* \begin{code} -findAndReadIface :: SDoc -> ModuleName +findAndReadIface :: Bool -- True <=> explicit user import + -> SDoc -> Module -> IsBootInterface -- True <=> Look for a .hi-boot file -- False <=> Look for .hi file -> IfM lcl (Either Message ModIface) @@ -541,7 +548,7 @@ findAndReadIface :: SDoc -> ModuleName -- It *doesn't* add an error to the monad, because -- sometimes it's ok to fail... see notes with loadInterface -findAndReadIface doc_str mod_name hi_boot_file +findAndReadIface explicit doc_str mod_name hi_boot_file = do { traceIf (sep [hsep [ptext SLIT("Reading"), if hi_boot_file then ptext SLIT("[boot]") @@ -551,19 +558,26 @@ findAndReadIface doc_str mod_name hi_boot_file nest 4 (ptext SLIT("reason:") <+> doc_str)]) -- Check for GHC.Prim, and return its static interface - ; if mod_name == gHC_PRIM_Name - then returnM (Right ghcPrimIface) + ; dflags <- getDOpts + ; let base_id = basePackageId (pkgState dflags) + base_pkg + | Just id <- base_id = ExternalPackage id + | otherwise = ThisPackage + -- if basePackageId is Nothing, it means we must be + -- compiling the base package. + ; if mod_name == gHC_PRIM + then returnM (Right (ghcPrimIface{ mi_package = base_pkg })) else do -- Look for the file - ; mb_found <- ioToIOEnv (findHiFile mod_name hi_boot_file) + ; mb_found <- ioToIOEnv (findHiFile dflags explicit mod_name hi_boot_file) ; case mb_found of { - Left files -> do + Left err -> do { traceIf (ptext SLIT("...not found")) ; dflags <- getDOpts - ; returnM (Left (noIfaceErr dflags mod_name hi_boot_file files)) } ; + ; returnM (Left (noIfaceErr dflags mod_name err)) } ; - Right file_path -> do + Right (file_path,pkg) -> do -- Found file, so read it { traceIf (ptext SLIT("readIFace") <+> text file_path) @@ -571,15 +585,16 @@ findAndReadIface doc_str mod_name hi_boot_file ; case read_result of Left err -> returnM (Left (badIfaceFile file_path err)) Right iface - | moduleName (mi_module iface) /= mod_name -> + | mi_module iface /= mod_name -> return (Left (wrongIfaceModErr iface mod_name file_path)) | otherwise -> - returnM (Right iface) + returnM (Right iface{mi_package=pkg}) + -- don't forget to fill in the package name... }}} -findHiFile :: ModuleName -> IsBootInterface - -> IO (Either [FilePath] FilePath) -findHiFile mod_name hi_boot_file +findHiFile :: DynFlags -> Bool -> Module -> IsBootInterface + -> IO (Either FindResult (FilePath, IfacePackage)) +findHiFile dflags 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. @@ -590,13 +605,15 @@ findHiFile mod_name hi_boot_file let { home_allowed = hi_boot_file || not (isCompManagerMode ghci_mode) } ; maybe_found <- if home_allowed - then findModule mod_name - else findPackageModule mod_name ; + then findModule dflags mod_name explicit + else findPackageModule dflags mod_name explicit; case maybe_found of { - Left files -> return (Left files) ; - - Right (_, loc) -> do { -- Don't need module returned by finder + Found loc pkg -> foundOk loc hi_boot_file pkg; + err -> return (Left err) ; + }} + where + foundOk loc hi_boot_file pkg = do { -- Don't need module returned by finder -- Return the path to M.hi, M.hi-boot, or M.hi-boot-n as appropriate let { hi_path = ml_hi_file loc ; @@ -605,18 +622,18 @@ findHiFile mod_name hi_boot_file }; if not hi_boot_file then - return (Right hi_path) + return (Right (hi_path,pkg)) else do { hi_ver_exists <- doesFileExist hi_boot_ver_path ; - if hi_ver_exists then return (Right hi_boot_ver_path) - else return (Right hi_boot_path) - }}}} + if hi_ver_exists then return (Right (hi_boot_ver_path,pkg)) + else return (Right (hi_boot_path,pkg)) + }} \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: ModuleName -> String -> IsBootInterface +readIface :: Module -> String -> IsBootInterface -> IfM lcl (Either Message ModIface) -- Left err <=> file not found, or unreadable, or illegible -- Right iface <=> successfully found and parsed @@ -637,7 +654,7 @@ read_iface dflags wanted_mod file_path is_hi_boot_file | wanted_mod == actual_mod -> return (Right iface) | otherwise -> return (Left err) where - actual_mod = moduleName (mi_module iface) + actual_mod = mi_module iface err = hiModuleNameMismatchWarn wanted_mod actual_mod }} @@ -675,7 +692,7 @@ initExternalPackageState } where mk_gated_rule (fn_name, core_rule) - = ([fn_name], (nameModuleName fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)) + = ([fn_name], (nameModule fn_name, IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)) \end{code} @@ -688,8 +705,8 @@ initExternalPackageState \begin{code} ghcPrimIface :: ModIface ghcPrimIface - = (emptyModIface basePackage gHC_PRIM_Name) { - mi_exports = [(gHC_PRIM_Name, ghcPrimExports)], + = (emptyModIface ThisPackage gHC_PRIM) { + mi_exports = [(gHC_PRIM, ghcPrimExports)], mi_decls = [], mi_fixities = fixities, mi_fix_fn = mkIfaceFixCache fixities @@ -734,7 +751,7 @@ badIfaceFile file err = vcat [ptext SLIT("Bad interface file:") <+> text file, nest 4 err] -hiModuleNameMismatchWarn :: ModuleName -> ModuleName -> Message +hiModuleNameMismatchWarn :: Module -> Module -> Message hiModuleNameMismatchWarn requested_mod read_mod = hsep [ ptext SLIT("Something is amiss; requested module name") , ppr requested_mod @@ -742,11 +759,21 @@ hiModuleNameMismatchWarn requested_mod read_mod = , ppr read_mod ] -noIfaceErr dflags mod_name boot_file files +noIfaceErr dflags mod_name (PackageHidden pkg) + = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon + $$ ptext SLIT("it is a member of package") <+> quotes (ppr pkg) <> comma + <+> ptext SLIT("which is hidden") + +noIfaceErr dflags mod_name (ModuleHidden pkg) + = ptext SLIT("Could not import") <+> quotes (ppr mod_name) <> colon + $$ ptext SLIT("it is hidden") + <+> parens (ptext SLIT("in package") <+> quotes (ppr pkg)) + +noIfaceErr dflags mod_name (NotFound files) = ptext SLIT("Could not find interface file for") <+> quotes (ppr mod_name) - $$ extra + $$ extra files where - extra + extra files | verbosity dflags < 3 = text "(use -v to see a list of the files searched for)" | otherwise = diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index abfc67d5c1..ebbca13e8c 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -174,6 +174,7 @@ compiled with -O. I think this is the case.] #include "HsVersions.h" import HsSyn +import Packages ( isHomeModule ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..), eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool, @@ -184,10 +185,9 @@ import BasicTypes ( Version, initialVersion, bumpVersion ) import TcRnMonad import TcRnTypes ( ImportAvails(..), mkModDeps ) import TcType ( isFFITy ) -import HscTypes ( ModIface(..), TyThing(..), +import HscTypes ( ModIface(..), TyThing(..), IfacePackage(..), ModGuts(..), ModGuts, IfaceExport, - GhciMode(..), isOneShot, - HscEnv(..), hscEPS, + GhciMode(..), HscEnv(..), hscEPS, Dependencies(..), FixItem(..), mkIfaceDepCache, mkIfaceFixCache, mkIfaceVerCache, typeEnvElts, @@ -195,16 +195,18 @@ import HscTypes ( ModIface(..), TyThing(..), ExternalPackageState(..), Usage(..), IsBootInterface, Deprecs(..), IfaceDeprecs, Deprecations, - lookupIfaceByModName + lookupIfaceByModule ) import CmdLineOpts -import Name ( Name, nameModule, nameOccName, nameParent, isExternalName, - nameParent_maybe, isWiredInName, NamedThing(..), nameModuleName ) +import Name ( Name, nameModule, nameOccName, nameParent, + isExternalName, nameParent_maybe, isWiredInName, + NamedThing(..) ) import NameEnv import NameSet -import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccEnv_C, +import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, + extendOccEnv_C, OccSet, emptyOccSet, elemOccSet, occSetElts, extendOccSet, extendOccSetList, isEmptyOccSet, intersectOccSet, intersectsOccSet, @@ -212,10 +214,10 @@ import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOc import TyCon ( tyConDataCons, isNewTyCon, newTyConRep ) import Class ( classSelIds ) import DataCon ( dataConName, dataConFieldLabels ) -import Module ( Module, ModuleName, moduleNameFS, moduleName, isHomeModule, - ModLocation(..), mkSysModuleNameFS, moduleUserString, +import Module ( Module, moduleFS, + ModLocation(..), mkSysModuleFS, moduleUserString, ModuleEnv, emptyModuleEnv, lookupModuleEnv, - extendModuleEnv_C, moduleEnvElts + extendModuleEnv_C ) import Outputable import DriverUtil ( createDirectoryHierarchy, directoryOf ) @@ -264,8 +266,7 @@ mkIface hsc_env location maybe_old_iface mg_rules = rules, mg_types = type_env } = do { eps <- hscEPS hsc_env - ; let { this_mod_name = moduleName this_mod - ; ext_nm = mkExtNameFn hsc_env eps this_mod_name + ; let { ext_nm = mkExtNameFn hsc_env eps this_mod ; local_things = [thing | thing <- typeEnvElts type_env, not (isWiredInName (getName thing)) ] -- Do not export anything about wired-in things @@ -287,12 +288,12 @@ mkIface hsc_env location maybe_old_iface ; iface_rules | omit_prags = [] | otherwise = sortLe le_rule $ - map (coreRuleToIfaceRule this_mod_name ext_nm) rules + map (coreRuleToIfaceRule this_mod ext_nm) rules ; iface_insts = sortLe le_inst (map dfunToIfaceInst insts) ; intermediate_iface = ModIface { mi_module = this_mod, - mi_package = opt_InPackage, + mi_package = ThisPackage, mi_boot = False, mi_deps = deps, mi_usages = usages, @@ -383,36 +384,36 @@ wantDeclFor exports abstracts thing deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) ----------------------------- -mkExtNameFn :: HscEnv -> ExternalPackageState -> ModuleName -> Name -> IfaceExtName +mkExtNameFn :: HscEnv -> ExternalPackageState -> Module -> Name -> IfaceExtName mkExtNameFn hsc_env eps this_mod = ext_nm where + dflags = hsc_dflags hsc_env hpt = hsc_HPT hsc_env pit = eps_PIT eps ext_nm name - | mod_nm == this_mod = case nameParent_maybe name of + | mod == this_mod = case nameParent_maybe name of Nothing -> LocalTop occ Just par -> LocalTopSub occ (nameOccName par) - | isWiredInName name = ExtPkg mod_nm occ - | isHomeModule mod = HomePkg mod_nm occ vers - | otherwise = ExtPkg mod_nm occ + | isWiredInName name = ExtPkg mod occ + | isHomeModule dflags mod = HomePkg mod occ vers + | otherwise = ExtPkg mod occ where mod = nameModule name - mod_nm = moduleName mod occ = nameOccName name par_occ = nameOccName (nameParent name) -- The version of the *parent* is the one want - vers = lookupVersion mod_nm par_occ + vers = lookupVersion mod par_occ - lookupVersion :: ModuleName -> OccName -> Version + lookupVersion :: Module -> OccName -> Version -- Even though we're looking up a home-package thing, in -- one-shot mode the imported interfaces may be in the PIT lookupVersion mod occ = mi_ver_fn iface occ `orElse` pprPanic "lookupVers1" (ppr mod <+> ppr occ) where - iface = lookupIfaceByModName hpt pit mod `orElse` + iface = lookupIfaceByModule hpt pit mod `orElse` pprPanic "lookupVers2" (ppr mod <+> ppr occ) ----------------------------- @@ -666,21 +667,24 @@ bump_unless False v = bumpVersion v \begin{code} mkUsageInfo :: HscEnv -> ModuleEnv (Module, Maybe Bool, SrcSpan) - -> [(ModuleName, IsBootInterface)] + -> [(Module, IsBootInterface)] -> NameSet -> IO [Usage] mkUsageInfo hsc_env dir_imp_mods dep_mods used_names = do { eps <- hscEPS hsc_env - ; let usages = mk_usage_info (eps_PIT eps) (hsc_HPT hsc_env) + ; 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 hpt 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 + dflags = hsc_dflags hsc_env + hpt = hsc_HPT hsc_env + used_names = mkNameSet $ -- Eliminate duplicates [ nameParent n -- Just record usage on the 'main' names | n <- nameSetToList proto_used_names @@ -708,23 +712,23 @@ mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names -- (need to recompile if its export list changes: export_vers) -- c) is a home-package orphan module (need to recompile if its -- instance decls change: rules_vers) - mkUsage :: (ModuleName, Bool) -> Maybe Usage + mkUsage :: (Module, Bool) -> Maybe Usage mkUsage (mod_name, _) | isNothing maybe_iface -- We can't depend on it if we didn't - || not (isHomeModule mod) -- even open the interface! + || not (isHomeModule dflags mod) -- even open the interface! || (null used_occs && not all_imported && not orphan_mod) = Nothing -- Record no usage info | otherwise - = Just (Usage { usg_name = moduleName mod, + = Just (Usage { usg_name = mod, usg_mod = mod_vers, usg_exports = export_vers, usg_entities = ent_vers, usg_rules = rules_vers }) where - maybe_iface = lookupIfaceByModName hpt pit mod_name + maybe_iface = lookupIfaceByModule hpt pit mod_name -- In one-shot mode, the interfaces for home-package -- modules accumulate in the PIT not HPT. Sigh. @@ -746,11 +750,11 @@ mk_usage_info pit hpt dir_imp_mods dep_mods proto_used_names \end{code} \begin{code} -mkIfaceExports :: NameSet -> [(ModuleName, [GenAvailInfo OccName])] +mkIfaceExports :: NameSet -> [(Module, [GenAvailInfo OccName])] -- Group by module and sort by occurrence -- This keeps the list in canonical order mkIfaceExports exports - = [ (mkSysModuleNameFS fs, eltsFM avails) + = [ (mkSysModuleFS fs, eltsFM avails) | (fs, avails) <- fmToList groupFM ] where @@ -763,7 +767,7 @@ mkIfaceExports exports (unitFM avail_fs avail) where occ = nameOccName name - mod_fs = moduleNameFS (nameModuleName name) + mod_fs = moduleFS (nameModule name) avail | Just p <- nameParent_maybe name = AvailTC (nameOccName p) [occ] | isTcOcc occ = AvailTC occ [occ] | otherwise = Avail occ @@ -821,7 +825,7 @@ check_old_iface this_mod iface_path source_unchanged maybe_iface -- Try and read the old interface for the current module -- from the .hi file left from the last time we compiled it - readIface (moduleName this_mod) iface_path False `thenM` \ read_result -> + readIface this_mod iface_path False `thenM` \ read_result -> case read_result of { Left err -> -- Old interface file not found, or garbled; give up traceIf (text "FYI: cannot read old interface file:" @@ -872,7 +876,7 @@ checkVersions source_unchanged iface } where -- This is a bit of a hack really - mod_deps :: ModuleEnv (ModuleName, IsBootInterface) + mod_deps :: ModuleEnv (Module, IsBootInterface) mod_deps = mkModDeps (dep_mods (mi_deps iface)) checkModUsage :: Usage -> IfG RecompileRequired @@ -1001,7 +1005,7 @@ pprModIface :: ModIface -> SDoc -- Show a ModIface pprModIface iface = vcat [ ptext SLIT("interface") - <+> doubleQuotes (ftext (mi_package iface)) + <+> ppr_package (mi_package iface) <+> ppr (mi_module iface) <+> ppr (mi_mod_vers iface) <+> pp_sub_vers <+> (if mi_orphan iface then ptext SLIT("[orphan module]") else empty) @@ -1017,6 +1021,9 @@ pprModIface iface , pprDeprecs (mi_deprecs iface) ] where + ppr_package ThisPackage = empty + ppr_package (ExternalPackage id) = doubleQuotes (ftext id) + exp_vers = mi_exp_vers iface rule_vers = mi_rule_vers iface diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 2a875e05f3..7f4e83e395 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -49,11 +49,11 @@ import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon ) import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) import Var ( TyVar, mkTyVar, tyVarKind ) -import Name ( Name, nameModuleName, nameModule, nameIsLocalOrFrom, +import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, wiredInNameTyThing_maybe, nameParent ) import NameEnv import OccName ( OccName ) -import Module ( Module, ModuleName, moduleName ) +import Module ( Module ) import UniqSupply ( initUs_ ) import Outputable import SrcLoc ( noSrcLoc ) @@ -168,10 +168,10 @@ typecheckIface hsc_env iface ; rules | ignore_prags = [] | otherwise = mi_rules iface ; dfuns = mi_insts iface - ; mod_name = moduleName (mi_module iface) + ; mod = mi_module iface } -- Typecheck the decls - ; names <- mappM (lookupOrig mod_name . ifName) decls + ; names <- mappM (lookupOrig mod . ifName) decls ; ty_things <- fixM (\ rec_ty_things -> do { writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things)) -- This only makes available the "main" things, @@ -449,7 +449,7 @@ tcIfaceInst :: IfaceInst -> IfL DFunId tcIfaceInst (IfaceInst { ifDFun = dfun_occ }) = tcIfaceExtId (LocalTop dfun_occ) -selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(ModuleName, IfaceInst)]) +selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(Module, IfaceInst)]) selectInsts cls tycons eps = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts) where @@ -521,7 +521,7 @@ loadImportedRules hsc_env guts } -selectRules :: ExternalPackageState -> (ExternalPackageState, [(ModuleName, IfaceRule)]) +selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, IfaceRule)]) -- Not terribly efficient. Look at each rule in the pool to see if -- all its gates are in the type env. If so, take it out of the pool. -- If not, trim its gates for next time. @@ -701,7 +701,7 @@ tcIfaceAlt _ (IfaceLitAlt lit, names, rhs) -- by the fact that we omit type annotations because we can -- work them out. True enough, but its not that easy! tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs) - = do { let tycon_mod = nameModuleName (tyConName tycon) + = do { let tycon_mod = nameModule (tyConName tycon) ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ) ; ASSERT2( con `elem` tyConDataCons tycon, ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) ) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 2cf2841cf8..6942408563 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -13,6 +13,7 @@ module CmdLineOpts ( HscLang(..), DynFlag(..), -- needed non-abstractly by DriverFlags DynFlags(..), + PackageFlag(..), v_Static_hsc_opts, @@ -27,18 +28,8 @@ module CmdLineOpts ( dopt_HscLang, -- DynFlags -> HscLang dopt_OutName, -- DynFlags -> String getOpts, -- (DynFlags -> [a]) -> IO [a] - setLang, getVerbFlag, - setOptLevel, - - -- Manipulating the DynFlags state - getDynFlags, -- IO DynFlags - setDynFlags, -- DynFlags -> IO () - updDynFlags, -- (DynFlags -> DynFlags) -> IO () - dynFlag, -- (DynFlags -> a) -> IO a - setDynFlag, unSetDynFlag, -- DynFlag -> IO () - saveDynFlags, -- IO () - restoreDynFlags, -- IO DynFlags + updOptLevel, -- sets of warning opts minusWOpts, @@ -84,7 +75,6 @@ module CmdLineOpts ( -- misc opts opt_ErrorSpans, - opt_InPackage, opt_EmitCExternDecls, opt_EnsureSplittableC, opt_GranMacros, @@ -99,6 +89,7 @@ module CmdLineOpts ( #include "HsVersions.h" +import {-# SOURCE #-} Packages (PackageState) import Constants -- Default values for some flags import Util import FastString ( FastString, mkFastString ) @@ -107,7 +98,7 @@ import Maybes ( firstJust ) import Panic ( ghcError, GhcException(UsageError) ) import GLAEXTS -import DATA_IOREF ( IORef, readIORef, writeIORef ) +import DATA_IOREF ( IORef, readIORef ) import UNSAFE_IO ( unsafePerformIO ) \end{code} @@ -314,6 +305,7 @@ data DynFlags = DynFlags { ppFlag :: Bool, -- preprocess with a Haskell Pp? stolen_x86_regs :: Int, cmdlineHcIncludes :: [String], -- -#includes + importPaths :: [FilePath], -- options for particular phases opt_L :: [String], @@ -327,10 +319,30 @@ data DynFlags = DynFlags { opt_i :: [String], #endif + -- ** Package flags + extraPkgConfs :: [FilePath], + -- The -package-conf flags given on the command line, in the order + -- they appeared. + + readUserPkgConf :: Bool, + -- Whether or not to read the user package database + -- (-no-user-package-conf). + + packageFlags :: [PackageFlag], + -- The -package and -hide-package flags from the command-line + + -- ** Package state + pkgState :: PackageState, + -- hsc dynamic flags flags :: [DynFlag] } +data PackageFlag + = ExposePackage String + | HidePackage String + | IgnorePackage String + data HscLang = HscC | HscAsm @@ -361,6 +373,7 @@ defaultDynFlags = DynFlags { ppFlag = False, stolen_x86_regs = 4, cmdlineHcIncludes = [], + importPaths = ["."], opt_L = [], opt_P = [], opt_F = [], @@ -371,6 +384,12 @@ defaultDynFlags = DynFlags { opt_I = [], opt_i = [], #endif + + extraPkgConfs = [], + readUserPkgConf = True, + packageFlags = [], + pkgState = error "pkgState", + flags = [ Opt_Generics, -- Generating the helper-functions for @@ -426,33 +445,18 @@ dopt_set dfs f = dfs{ flags = f : flags dfs } dopt_unset :: DynFlags -> DynFlag -> DynFlags dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } -getOpts :: (DynFlags -> [a]) -> IO [a] +getOpts :: DynFlags -> (DynFlags -> [a]) -> [a] -- We add to the options from the front, so we need to reverse the list -getOpts opts = dynFlag opts >>= return . reverse - --- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags --- (-fvia-C, -fasm, -filx respectively). -setLang l = updDynFlags (\ dfs -> case hscLang dfs of - HscC -> dfs{ hscLang = l } - HscAsm -> dfs{ hscLang = l } - HscILX -> dfs{ hscLang = l } - _ -> dfs) +getOpts dflags opts = reverse (opts dflags) -getVerbFlag = do - verb <- dynFlag verbosity - if verb >= 3 then return "-v" else return "" +getVerbFlag dflags + | verbosity dflags >= 3 = "-v" + | otherwise = "" ----------------------------------------------------------------------------- -- Setting the optimisation level -setOptLevel :: Int -> IO () -setOptLevel n - = do dflags <- getDynFlags - if hscLang dflags == HscInterpreted && n > 0 - then putStr "warning: -O conflicts with --interactive; -O ignored.\n" - else updDynFlags (setOptLevel' n) - -setOptLevel' n dfs +updOptLevel n dfs = if (n >= 1) then dfs2{ hscLang = HscC, optLevel = n } -- turn on -fvia-C with -O else dfs2{ optLevel = n } @@ -611,51 +615,8 @@ buildCoreToDo dflags = core_todo MaxSimplifierIterations max_iter ] ] - --- -------------------------------------------------------------------------- --- Mess about with the mutable variables holding the dynamic arguments - --- v_InitDynFlags --- is the "baseline" dynamic flags, initialised from --- the defaults and command line options, and updated by the --- ':s' command in GHCi. --- --- v_DynFlags --- is the dynamic flags for the current compilation. It is reset --- to the value of v_InitDynFlags before each compilation, then --- updated by reading any OPTIONS pragma in the current module. - -GLOBAL_VAR(v_InitDynFlags, defaultDynFlags, DynFlags) -GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags) - -setDynFlags :: DynFlags -> IO () -setDynFlags dfs = writeIORef v_DynFlags dfs - -saveDynFlags :: IO () -saveDynFlags = do dfs <- readIORef v_DynFlags - writeIORef v_InitDynFlags dfs - -restoreDynFlags :: IO DynFlags -restoreDynFlags = do dfs <- readIORef v_InitDynFlags - writeIORef v_DynFlags dfs - return dfs - -getDynFlags :: IO DynFlags -getDynFlags = readIORef v_DynFlags - -updDynFlags :: (DynFlags -> DynFlags) -> IO () -updDynFlags f = do dfs <- readIORef v_DynFlags - writeIORef v_DynFlags (f dfs) - -dynFlag :: (DynFlags -> a) -> IO a -dynFlag f = do dflags <- readIORef v_DynFlags; return (f dflags) - -setDynFlag, unSetDynFlag :: DynFlag -> IO () -setDynFlag f = updDynFlags (\dfs -> dopt_set dfs f) -unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f) \end{code} - %************************************************************************ %* * \subsection{Warnings} @@ -701,7 +662,6 @@ minusWallOpts GLOBAL_VAR(v_Static_hsc_opts, [], [String]) lookUp :: FastString -> Bool -lookup_int :: String -> Maybe Int lookup_def_int :: String -> Int -> Int lookup_def_float :: String -> Float -> Float lookup_str :: String -> Maybe String @@ -719,10 +679,6 @@ lookup_str sw Just str -> Just str Nothing -> Nothing -lookup_int sw = case (lookup_str sw) of - Nothing -> Nothing - Just xx -> Just (try_read sw xx) - lookup_def_int sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> try_read sw xx @@ -796,15 +752,6 @@ opt_RulesOff = lookUp FSLIT("-frules-off") opt_LiberateCaseThreshold = lookup_def_int "-fliberate-case-threshold" (10::Int) opt_MaxWorkerArgs = lookup_def_int "-fmax-worker-args" (10::Int) -{- - The optional '-inpackage=P' flag tells what package - we are compiling this module for. - The Prelude, for example is compiled with '-inpackage std' --} -opt_InPackage = case lookup_str "-inpackage=" of - Just p -> mkFastString p - Nothing -> FSLIT("Main") -- The package name if none is specified - opt_EmitCExternDecls = lookUp FSLIT("-femit-extern-decls") opt_EnsureSplittableC = lookUp FSLIT("-fglobalise-toplev-names") opt_GranMacros = lookUp FSLIT("-fgransim") diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index 695162cdf1..3a3e4bbf17 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -28,7 +28,6 @@ import Distribution.Package ( showPackageId ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages -import DriverState ( getExplicitPackagesAnd, getPackageCIncludes ) import DriverUtil ( filenameOf ) import FastString ( unpackFS ) import Cmm ( Cmm ) @@ -125,7 +124,7 @@ outputC dflags filenm flat_absC -- * the _stub.h file, if there is one. -- let packages = dep_pkgs dependencies - pkg_configs <- getExplicitPackagesAnd packages + pkg_configs <- getExplicitPackagesAnd dflags packages let pkg_names = map (showPackageId.package) pkg_configs c_includes <- getPackageCIncludes pkg_configs @@ -244,8 +243,12 @@ outputForeignStubs dflags (ForeignStubs h_code c_code _ _) "Foreign export header file" stub_h_output_d -- we need the #includes from the rts package for the stub files - rts_pkgs <- getPackageDetails [rtsPackage] - let rts_includes = concatMap mk_include (concatMap includes rts_pkgs) + let rtsid = rtsPackageId (pkgState dflags) + rts_includes + | Just pid <- rtsid = + let rts_pkg = getPackageDetails (pkgState dflags) pid in + concatMap mk_include (includes rts_pkg) + | otherwise = [] mk_include i = "#include \"" ++ i ++ "\"\n" stub_h_file_exists diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs index 0f91cb18a6..0aa9563caa 100644 --- a/ghc/compiler/main/DriverFlags.hs +++ b/ghc/compiler/main/DriverFlags.hs @@ -7,10 +7,14 @@ ----------------------------------------------------------------------------- module DriverFlags ( - processArgs, OptKind(..), static_flags, dynamic_flags, + processDynamicFlags, + processStaticFlags, + addCmdlineHCInclude, buildStaticHscOpts, - machdepCCOpts + machdepCCOpts, + + processArgs, OptKind(..), -- for DriverMkDepend only ) where #include "HsVersions.h" @@ -25,9 +29,10 @@ import CmdLineOpts import Config import Util import Panic +import FastString ( mkFastString ) import EXCEPTION -import DATA_IOREF ( readIORef, writeIORef ) +import DATA_IOREF ( IORef, readIORef, writeIORef ) import System ( exitWith, ExitCode(..) ) import IO @@ -57,6 +62,9 @@ import Char ----------------------------------------------------------------------------- -- Process command-line +processStaticFlags :: [String] -> IO [String] +processStaticFlags opts = processArgs static_flags opts [] + data OptKind = NoArg (IO ()) -- flag with no argument | HasArg (String -> IO ()) -- flag has an argument (maybe prefix) @@ -258,7 +266,6 @@ static_flags = ) ) ------- Include/Import Paths ---------------------------------------- - , ( "i" , OptPrefix (addToOrDeleteDirList v_Import_paths) ) , ( "I" , Prefix (addToDirList v_Include_paths) ) ------- Libraries --------------------------------------------------- @@ -271,13 +278,6 @@ static_flags = , ( "framework-path" , HasArg (addToDirList v_Framework_paths) ) , ( "framework" , HasArg (add v_Cmdline_frameworks) ) #endif - ------- Packages ---------------------------------------------------- - , ( "package-name" , HasArg (\s -> add v_Opt_C ("-inpackage="++s)) ) - - , ( "package-conf" , HasArg (readPackageConf) ) - , ( "package" , HasArg (addPackage) ) - , ( "syslib" , HasArg (addPackage) ) -- for compatibility w/ old vsns - ------- Specific phases -------------------------------------------- , ( "pgmL" , HasArg setPgmL ) , ( "pgmP" , HasArg setPgmP ) @@ -340,10 +340,22 @@ dynamic_flags = [ , ( "opti", HasArg (addOpt_i) ) #endif + ------- Packages ---------------------------------------------------- + , ( "package-conf" , HasArg extraPkgConf_ ) + , ( "no-user-package-conf", NoArg noUserPkgConf_ ) + , ( "package-name" , HasArg ignorePackage ) -- for compatibility + , ( "package" , HasArg exposePackage ) + , ( "hide-package" , HasArg hidePackage ) + , ( "ignore-package" , HasArg ignorePackage ) + , ( "syslib" , HasArg exposePackage ) -- for compatibility + ------ HsCpp opts --------------------------------------------------- , ( "D", AnySuffix addOpt_P ) , ( "U", AnySuffix addOpt_P ) + ------- Paths & stuff ----------------------------------------------- + , ( "i" , OptPrefix addImportPath ) + ------ Debugging ---------------------------------------------------- , ( "dstg-stats", NoArg (writeIORef v_StgStats True) ) @@ -480,6 +492,75 @@ glasgowExtsFlags = [ Opt_GlasgowExts, Opt_FFI, Opt_TH, Opt_ImplicitParams ] isFFlag f = f `elem` (map fst fFlags) getFFlag f = fromJust (lookup f fFlags) +-- ----------------------------------------------------------------------------- +-- Parsing the dynamic flags. + +-- we use a temporary global variable, for convenience + +GLOBAL_VAR(v_DynFlags, defaultDynFlags, DynFlags) + +processDynamicFlags :: [String] -> DynFlags -> IO (DynFlags,[String]) +processDynamicFlags args dflags = do + writeIORef v_DynFlags dflags + spare <- processArgs dynamic_flags args [] + dflags <- readIORef v_DynFlags + return (dflags,spare) + +updDynFlags :: (DynFlags -> DynFlags) -> IO () +updDynFlags f = do dfs <- readIORef v_DynFlags + writeIORef v_DynFlags (f dfs) + +setDynFlag, unSetDynFlag :: DynFlag -> IO () +setDynFlag f = updDynFlags (\dfs -> dopt_set dfs f) +unSetDynFlag f = updDynFlags (\dfs -> dopt_unset dfs f) + +addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s}) +addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s}) +addOpt_F a = updDynFlags (\s -> s{opt_F = a : opt_F s}) +addOpt_c a = updDynFlags (\s -> s{opt_c = a : opt_c s}) +addOpt_a a = updDynFlags (\s -> s{opt_a = a : opt_a s}) +addOpt_m a = updDynFlags (\s -> s{opt_m = a : opt_m s}) +#ifdef ILX +addOpt_I a = updDynFlags (\s -> s{opt_I = a : opt_I s}) +addOpt_i a = updDynFlags (\s -> s{opt_i = a : opt_i s}) +#endif + +setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 }) +setVerbosity n + | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n }) + | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v<n>)") + +addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) + +extraPkgConf_ p = updDynFlags (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) +noUserPkgConf_ = updDynFlags (\s -> s{ readUserPkgConf = False }) + +exposePackage p = + updDynFlags (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) +hidePackage p = + updDynFlags (\s -> s{ packageFlags = HidePackage p : packageFlags s }) +ignorePackage p = + updDynFlags (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) + +-- -i on its own deletes the import paths +addImportPath "" = updDynFlags (\s -> s{importPaths = []}) +addImportPath p = updDynFlags (\s -> s{importPaths = p : importPaths s}) + +-- we can only switch between HscC, HscAsmm, and HscILX with dynamic flags +-- (-fvia-C, -fasm, -filx respectively). +setLang l = updDynFlags (\dfs -> case hscLang dfs of + HscC -> dfs{ hscLang = l } + HscAsm -> dfs{ hscLang = l } + HscILX -> dfs{ hscLang = l } + _ -> dfs) + +setOptLevel :: Int -> IO () +setOptLevel n + = do dflags <- readIORef v_DynFlags + if hscLang dflags == HscInterpreted && n > 0 + then putStr "warning: -O conflicts with --interactive; -O ignored.\n" + else writeIORef v_DynFlags (updOptLevel n dflags) + ----------------------------------------------------------------------------- -- convert sizes like "3.5M" into integers @@ -547,7 +628,7 @@ setMainIs arg -- , registerised HC compilations -- ) -machdepCCOpts +machdepCCOpts dflags | prefixMatch "alpha" cTARGETPLATFORM = return ( ["-w", "-mieee" #ifdef HAVE_THREADED_RTS_SUPPORT @@ -580,7 +661,7 @@ machdepCCOpts -- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing -- the fp (%ebp) for our register maps. - = do n_regs <- dynFlag stolen_x86_regs + = do let n_regs = stolen_x86_regs dflags sta <- readIORef v_Static return ( [ if sta then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" -- , if suffixMatch "mingw32" cTARGETPLATFORM then "-mno-cygwin" else "" @@ -642,24 +723,6 @@ machdepCCOpts ----------------------------------------------------------------------------- -- local utils -addOpt_L a = updDynFlags (\s -> s{opt_L = a : opt_L s}) -addOpt_P a = updDynFlags (\s -> s{opt_P = a : opt_P s}) -addOpt_F a = updDynFlags (\s -> s{opt_F = a : opt_F s}) -addOpt_c a = updDynFlags (\s -> s{opt_c = a : opt_c s}) -addOpt_a a = updDynFlags (\s -> s{opt_a = a : opt_a s}) -addOpt_m a = updDynFlags (\s -> s{opt_m = a : opt_m s}) -#ifdef ILX -addOpt_I a = updDynFlags (\s -> s{opt_I = a : opt_I s}) -addOpt_i a = updDynFlags (\s -> s{opt_i = a : opt_i s}) -#endif - -setVerbosity "" = updDynFlags (\dfs -> dfs{ verbosity = 3 }) -setVerbosity n - | all isDigit n = updDynFlags (\dfs -> dfs{ verbosity = read n }) - | otherwise = throwDyn (UsageError "can't parse verbosity flag (-v<n>)") - -addCmdlineHCInclude a = updDynFlags (\s -> s{cmdlineHcIncludes = a : cmdlineHcIncludes s}) - -- ----------------------------------------------------------------------------- -- Version and usage messages diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs index b376102e8c..dda568f165 100644 --- a/ghc/compiler/main/DriverMkDepend.hs +++ b/ghc/compiler/main/DriverMkDepend.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: DriverMkDepend.hs,v 1.33 2004/09/30 10:37:10 simonpj Exp $ +-- $Id: DriverMkDepend.hs,v 1.34 2004/11/26 16:20:52 simonmar Exp $ -- -- GHC Driver -- @@ -13,16 +13,17 @@ module DriverMkDepend ( #include "HsVersions.h" +import HscTypes ( IfacePackage(..) ) import GetImports ( getImports ) +import CmdLineOpts ( DynFlags ) import DriverState import DriverUtil import DriverFlags import SysTools ( newTempName ) import qualified SysTools -import Module ( ModuleName, ModLocation(..), - moduleNameUserString, isHomeModule ) +import Module ( Module, ModLocation(..), moduleUserString) import Finder ( findModule, hiBootExt, hiBootVerExt, - mkHomeModLocation ) + mkHomeModLocation, FindResult(..) ) import Util ( global, maybePrefixMatch ) import Panic @@ -52,7 +53,6 @@ GLOBAL_VAR(v_Dep_warnings, True, Bool); GLOBAL_VAR(v_Dep_makefile_hdl, error "dep_makefile_hdl", Maybe Handle); GLOBAL_VAR(v_Dep_tmp_file, error "dep_tmp_file", String); GLOBAL_VAR(v_Dep_tmp_hdl, error "dep_tmp_hdl", Handle); -GLOBAL_VAR(v_Dep_dir_contents, error "dep_dir_contents", [(String,[String])]); depStartMarker = "# DO NOT DELETE: Beginning of Haskell dependencies" depEndMarker = "# DO NOT DELETE: End of Haskell dependencies" @@ -119,32 +119,22 @@ beginMkDependHS = do -- write the magic marker into the tmp file hPutStrLn tmp_hdl depStartMarker - -- cache the contents of all the import directories, for future - -- reference. - import_dirs <- readIORef v_Import_paths - pkg_import_dirs <- getPackageImportPath - import_dir_contents <- mapM softGetDirectoryContents import_dirs - pkg_import_dir_contents <- mapM softGetDirectoryContents pkg_import_dirs - writeIORef v_Dep_dir_contents - (zip import_dirs import_dir_contents ++ - zip pkg_import_dirs pkg_import_dir_contents) - return () -doMkDependHSPhase basename suff input_fn +doMkDependHSPhase dflags basename suff input_fn = do src <- readFile input_fn let (import_sources, import_normals, mod_name) = getImports src let orig_fn = basename ++ '.':suff - (_, location') <- mkHomeModLocation mod_name orig_fn + location' <- mkHomeModLocation mod_name orig_fn -- take -ohi into account if present ohi <- readIORef v_Output_hi let location | Just fn <- ohi = location'{ ml_hi_file = fn } | otherwise = location' - deps_sources <- mapM (findDependency True orig_fn) import_sources - deps_normals <- mapM (findDependency False orig_fn) import_normals + deps_sources <- mapM (findDependency dflags True orig_fn) import_sources + deps_normals <- mapM (findDependency dflags False orig_fn) import_normals let deps = deps_sources ++ deps_normals osuf <- readIORef v_Object_suf @@ -210,8 +200,8 @@ doMkDependHSPhase basename suff input_fn -endMkDependHS :: IO () -endMkDependHS = do +endMkDependHS :: DynFlags -> IO () +endMkDependHS dflags = do makefile <- readIORef v_Dep_makefile makefile_hdl <- readIORef v_Dep_makefile_hdl tmp_file <- readIORef v_Dep_tmp_file @@ -239,25 +229,26 @@ endMkDependHS = do -- Create a backup of the original makefile when (isJust makefile_hdl) - (SysTools.copy ("Backing up " ++ makefile) makefile (makefile++".bak")) + (SysTools.copy dflags ("Backing up " ++ makefile) + makefile (makefile++".bak")) -- Copy the new makefile in place - SysTools.copy "Installing new makefile" tmp_file makefile + SysTools.copy dflags "Installing new makefile" tmp_file makefile -findDependency :: Bool -> FilePath -> ModuleName -> IO (Maybe (String, Bool)) -findDependency is_source src imp = do +findDependency :: DynFlags -> Bool -> FilePath -> Module -> IO (Maybe (String, Bool)) +findDependency dflags is_source src imp = do excl_mods <- readIORef v_Dep_exclude_mods include_prelude <- readIORef v_Dep_include_prelude - let imp_mod = moduleNameUserString imp + let imp_mod = moduleUserString imp if imp_mod `elem` excl_mods then return Nothing else do - r <- findModule imp + r <- findModule dflags imp True{-explicit-} case r of - Right (mod,loc) + Found loc pkg -- not in this package: we don't need a dependency - | not (isHomeModule mod) && not include_prelude + | ExternalPackage _ <- pkg, not include_prelude -> return Nothing -- normal import: just depend on the .hi file @@ -280,6 +271,6 @@ findDependency is_source src imp = do then return (Just (boot_hi_file, not is_source)) else return (Just (hi_file, not is_source)) - Left _ -> throwDyn (ProgramError + _ -> throwDyn (ProgramError (src ++ ": " ++ "can't locate import `" ++ imp_mod ++ "'" ++ if is_source then " (SOURCE import)" else "")) diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index f4ec7877bf..9d8de34acb 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -66,11 +66,10 @@ import Maybe -- Just preprocess a file, put the result in a temp. file (used by the -- compilation manager during the summary phase). -preprocess :: FilePath -> IO FilePath -preprocess filename = +preprocess :: DynFlags -> FilePath -> IO FilePath +preprocess dflags filename = ASSERT(isHaskellSrcFilename filename) - do restoreDynFlags -- Restore to state of last save - runPipeline (StopBefore Hsc) ("preprocess") + do runPipeline (StopBefore Hsc) dflags ("preprocess") False{-temporary output file-} Nothing{-no specific output file-} filename @@ -119,24 +118,24 @@ compile hsc_env this_mod location src_timestamp source_unchanged have_object old_iface = do - dyn_flags <- restoreDynFlags -- Restore to the state of the last save + let dyn_flags = hsc_dflags hsc_env - showPass dyn_flags + showPass dyn_flags (showSDoc (text "Compiling" <+> ppr this_mod)) let verb = verbosity dyn_flags let input_fn = expectJust "compile:hs" (ml_hs_file location) let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location) - let mod_name = moduleName this_mod when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp)) + -- add in the OPTIONS from the source file opts <- getOptionsFromSource input_fnpp - processArgs dynamic_flags opts [] - dyn_flags <- getDynFlags + (dyn_flags,unhandled_flags) <- processDynamicFlags opts dyn_flags + checkProcessArgsResult unhandled_flags input_fn let (basename, _) = splitFilename input_fn - + -- We add the directory in which the .hs files resides) to the import path. -- This is needed when we try to compile the .hc file later, if it -- imports a _stub.h file that we created here. @@ -204,14 +203,14 @@ compile hsc_env this_mod location src_timestamp _other -> do let object_filename = ml_obj_file location - runPipeline (StopBefore Ln) "" + runPipeline (StopBefore Ln) dyn_flags "" True Nothing output_fn (Just location) -- the object filename comes from the ModLocation o_time <- getModificationTime object_filename return ([DotO object_filename], o_time) - let linkable = LM unlinked_time mod_name + let linkable = LM unlinked_time this_mod (hs_unlinked ++ stub_unlinked) return (CompOK details rdr_env iface (Just linkable)) @@ -224,7 +223,7 @@ compileStub dflags stub_c_exists | stub_c_exists = do -- compile the _stub.c file w/ gcc let stub_c = hscStubCOutName dflags - stub_o <- runPipeline (StopBefore Ln) "stub-compile" + stub_o <- runPipeline (StopBefore Ln) dflags "stub-compile" True{-persistent output-} Nothing{-no specific output file-} stub_c @@ -285,7 +284,7 @@ link Batch dflags batch_attempt_linking hpt obj_files = concatMap getOfiles linkables -- Don't showPass in Batch mode; doLink will do that for us. - staticLink obj_files pkg_deps + staticLink dflags obj_files pkg_deps when (verb >= 3) (hPutStrLn stderr "link: done") @@ -303,8 +302,13 @@ link Batch dflags batch_attempt_linking hpt -- --------------------------------------------------------------------------- -- Run a compilation pipeline, consisting of multiple phases. +-- The DynFlags can be modified by phases in the pipeline (eg. by +-- OPTIONS pragmas), and the changes affect later phases in the +-- pipeline, but we throw away the resulting DynFlags at the end. + runPipeline :: GhcMode -- when to stop + -> DynFlags -- dynamic flags -> String -- "stop after" flag -> Bool -- final output is persistent? -> Maybe FilePath -- where to put the output, optionally @@ -312,7 +316,8 @@ runPipeline -> Maybe ModLocation -- a ModLocation for this module, if we have one -> IO FilePath -- output filename -runPipeline todo stop_flag keep_output maybe_output_filename input_fn maybe_loc +runPipeline todo dflags stop_flag keep_output + maybe_output_filename input_fn maybe_loc = do split <- readIORef v_Split_object_files let (basename, suffix) = splitFilename input_fn @@ -345,7 +350,7 @@ runPipeline todo stop_flag keep_output maybe_output_filename input_fn maybe_loc -- and execute the pipeline... (output_fn, maybe_loc) <- - pipeLoop start_phase stop_phase input_fn basename suffix + pipeLoop dflags start_phase stop_phase input_fn basename suffix get_output_fn maybe_loc -- sometimes, a compilation phase doesn't actually generate any output @@ -355,18 +360,18 @@ runPipeline todo stop_flag keep_output maybe_output_filename input_fn maybe_loc if keep_output then do final_fn <- get_output_fn stop_phase maybe_loc when (final_fn /= output_fn) $ - copy ("Copying `" ++ output_fn ++ "' to `" ++ final_fn + copy dflags ("Copying `" ++ output_fn ++ "' to `" ++ final_fn ++ "'") output_fn final_fn return final_fn else return output_fn -pipeLoop :: Phase -> Phase -> FilePath -> String -> Suffix +pipeLoop :: DynFlags -> Phase -> Phase -> FilePath -> String -> Suffix -> (Phase -> Maybe ModLocation -> IO FilePath) -> Maybe ModLocation -> IO (FilePath, Maybe ModLocation) -pipeLoop phase stop_phase input_fn orig_basename orig_suff +pipeLoop dflags phase stop_phase input_fn orig_basename orig_suff get_output_fn maybe_loc | phase == stop_phase = return (input_fn, maybe_loc) -- all done @@ -380,16 +385,16 @@ pipeLoop phase stop_phase input_fn orig_basename orig_suff " but I wanted to stop at phase " ++ show stop_phase) | otherwise = do - maybe_next_phase <- runPhase phase orig_basename orig_suff input_fn - get_output_fn maybe_loc + maybe_next_phase <- runPhase phase dflags orig_basename + orig_suff input_fn get_output_fn maybe_loc case maybe_next_phase of - (Nothing, maybe_loc, output_fn) -> do + (Nothing, dflags, maybe_loc, output_fn) -> do -- we stopped early, but return the *final* filename -- (it presumably already exists) final_fn <- get_output_fn stop_phase maybe_loc return (final_fn, maybe_loc) - (Just next_phase, maybe_loc, output_fn) -> - pipeLoop next_phase stop_phase output_fn + (Just next_phase, dflags', maybe_loc, output_fn) -> + pipeLoop dflags' next_phase stop_phase output_fn orig_basename orig_suff get_output_fn maybe_loc @@ -459,84 +464,86 @@ genOutputFilenameFunc keep_final_output maybe_output_filename -- taking the via-C route to using the native code generator. runPhase :: Phase - -> String -- basename of original input source - -> String -- its extension - -> FilePath -- name of file which contains the input to this phase. - -> (Phase -> Maybe ModLocation -> IO FilePath) + -> DynFlags + -> String -- basename of original input source + -> String -- its extension + -> FilePath -- name of file which contains the input to this phase. + -> (Phase -> Maybe ModLocation -> IO FilePath) -- how to calculate the output filename - -> Maybe ModLocation -- the ModLocation, if we have one - -> IO (Maybe Phase, -- next phase - Maybe ModLocation, -- the ModLocation, if we have one - FilePath) -- output filename + -> Maybe ModLocation -- the ModLocation, if we have one + -> IO (Maybe Phase, -- next phase + DynFlags, -- new dynamic flags + Maybe ModLocation, -- the ModLocation, if we have one + FilePath) -- output filename ------------------------------------------------------------------------------- -- Unlit phase -runPhase Unlit _basename _suff input_fn get_output_fn maybe_loc - = do unlit_flags <- getOpts opt_L +runPhase Unlit dflags _basename _suff input_fn get_output_fn maybe_loc + = do let unlit_flags = getOpts dflags opt_L -- The -h option passes the file name for unlit to put in a #line directive output_fn <- get_output_fn Cpp maybe_loc - SysTools.runUnlit (map SysTools.Option unlit_flags ++ + SysTools.runUnlit dflags + (map SysTools.Option unlit_flags ++ [ SysTools.Option "-h" , SysTools.Option input_fn , SysTools.FileOption "" input_fn , SysTools.FileOption "" output_fn ]) - return (Just Cpp, maybe_loc, output_fn) + return (Just Cpp, dflags, maybe_loc, output_fn) ------------------------------------------------------------------------------- -- Cpp phase -runPhase Cpp basename suff input_fn get_output_fn maybe_loc +runPhase Cpp dflags basename suff input_fn get_output_fn maybe_loc = do src_opts <- getOptionsFromSource input_fn - unhandled_flags <- processArgs dynamic_flags src_opts [] - checkProcessArgsResult unhandled_flags basename suff + (dflags,unhandled_flags) <- processDynamicFlags src_opts dflags + checkProcessArgsResult unhandled_flags (basename++'.':suff) - do_cpp <- dynFlag cppFlag - if not do_cpp then + if not (cppFlag dflags) then -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. - return (Just HsPp, maybe_loc, input_fn) + return (Just HsPp, dflags, maybe_loc, input_fn) else do output_fn <- get_output_fn HsPp maybe_loc - doCpp True{-raw-} False{-no CC opts-} input_fn output_fn - return (Just HsPp, maybe_loc, output_fn) + doCpp dflags True{-raw-} False{-no CC opts-} input_fn output_fn + return (Just HsPp, dflags, maybe_loc, output_fn) ------------------------------------------------------------------------------- -- HsPp phase -runPhase HsPp basename suff input_fn get_output_fn maybe_loc - = do do_pp <- dynFlag ppFlag - if not do_pp then +runPhase HsPp dflags basename suff input_fn get_output_fn maybe_loc + = do if not (ppFlag dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. - return (Just Hsc, maybe_loc, input_fn) + return (Just Hsc, dflags, maybe_loc, input_fn) else do - hspp_opts <- getOpts opt_F + let hspp_opts = getOpts dflags opt_F hs_src_pp_opts <- readIORef v_Hs_source_pp_opts let orig_fn = basename ++ '.':suff output_fn <- get_output_fn Hsc maybe_loc - SysTools.runPp ( [ SysTools.Option orig_fn + SysTools.runPp dflags + ( [ SysTools.Option orig_fn , SysTools.Option input_fn , SysTools.FileOption "" output_fn ] ++ map SysTools.Option hs_src_pp_opts ++ map SysTools.Option hspp_opts ) - return (Just Hsc, maybe_loc, output_fn) + return (Just Hsc, dflags, maybe_loc, output_fn) ----------------------------------------------------------------------------- -- Hsc phase -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager). -runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do +runPhase Hsc dflags basename suff input_fn get_output_fn _maybe_loc = do todo <- readIORef v_GhcMode if todo == DoMkDependHS then do - locn <- doMkDependHSPhase basename suff input_fn - return (Nothing, Just locn, input_fn) -- Ln is a dummy stop phase + locn <- doMkDependHSPhase dflags basename suff input_fn + return (Nothing, dflags, Just locn, input_fn) -- Ln is a dummy stop phase else do -- normal Hsc mode, not mkdependHS @@ -555,12 +562,12 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do then do -- no explicit imports in ExtCore input. m <- getCoreModuleName input_fn - return ([], [], mkModuleName m) + return ([], [], mkModule m) else getImportsFromFile input_fn -- build a ModLocation to pass to hscMain. - (mod, location') <- mkHomeModLocation mod_name (basename ++ '.':suff) + location' <- mkHomeModLocation mod_name (basename ++ '.':suff) -- take -ohi into account if present ohi <- readIORef v_Output_hi @@ -598,20 +605,19 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do else return False -- get the DynFlags - dyn_flags <- getDynFlags - hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags) + hsc_lang <- hscMaybeAdjustLang (hscLang dflags) next_phase <- hscNextPhase hsc_lang output_fn <- get_output_fn next_phase (Just location) - let dyn_flags' = dyn_flags { hscLang = hsc_lang, - hscOutName = output_fn, - hscStubCOutName = basename ++ "_stub.c", - hscStubHOutName = basename ++ "_stub.h", - extCoreName = basename ++ ".hcr" } - hsc_env <- newHscEnv OneShot dyn_flags' + let dflags' = dflags { hscLang = hsc_lang, + hscOutName = output_fn, + hscStubCOutName = basename ++ "_stub.c", + hscStubHOutName = basename ++ "_stub.h", + extCoreName = basename ++ ".hcr" } + hsc_env <- newHscEnv OneShot dflags' -- run the compiler! - result <- hscMain hsc_env printErrorsAndWarnings mod + result <- hscMain hsc_env printErrorsAndWarnings mod_name location{ ml_hspp_file=Just input_fn } source_unchanged False @@ -622,49 +628,48 @@ runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do HscFail -> throwDyn (PhaseFailed "hsc" (ExitFailure 1)) HscNoRecomp details iface -> do - SysTools.touch "Touching object file" o_file - return (Nothing, Just location, output_fn) + SysTools.touch dflags' "Touching object file" o_file + return (Nothing, dflags', Just location, output_fn) HscRecomp _details _rdr_env _iface stub_h_exists stub_c_exists _maybe_interpreted_code -> do -- deal with stubs - maybe_stub_o <- compileStub dyn_flags' stub_c_exists + maybe_stub_o <- compileStub dflags' stub_c_exists case maybe_stub_o of Nothing -> return () Just stub_o -> add v_Ld_inputs stub_o - case hscLang dyn_flags of - HscNothing -> return (Nothing, Just location, output_fn) - _ -> return (Just next_phase, Just location, output_fn) + case hscLang dflags' of + HscNothing -> return (Nothing, dflags', Just location, output_fn) + _ -> return (Just next_phase, dflags', Just location, output_fn) ----------------------------------------------------------------------------- -- Cmm phase -runPhase CmmCpp basename suff input_fn get_output_fn maybe_loc +runPhase CmmCpp dflags basename suff input_fn get_output_fn maybe_loc = do output_fn <- get_output_fn Cmm maybe_loc - doCpp False{-not raw-} True{-include CC opts-} input_fn output_fn - return (Just Cmm, maybe_loc, output_fn) + doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn + return (Just Cmm, dflags, maybe_loc, output_fn) -runPhase Cmm basename suff input_fn get_output_fn maybe_loc +runPhase Cmm dflags basename suff input_fn get_output_fn maybe_loc = do - dyn_flags <- getDynFlags - hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags) + hsc_lang <- hscMaybeAdjustLang (hscLang dflags) next_phase <- hscNextPhase hsc_lang output_fn <- get_output_fn next_phase maybe_loc - let dyn_flags' = dyn_flags { hscLang = hsc_lang, - hscOutName = output_fn, - hscStubCOutName = basename ++ "_stub.c", - hscStubHOutName = basename ++ "_stub.h", - extCoreName = basename ++ ".hcr" } + let dflags' = dflags { hscLang = hsc_lang, + hscOutName = output_fn, + hscStubCOutName = basename ++ "_stub.c", + hscStubHOutName = basename ++ "_stub.h", + extCoreName = basename ++ ".hcr" } - ok <- hscCmmFile dyn_flags' input_fn + ok <- hscCmmFile dflags' input_fn when (not ok) $ throwDyn (PhaseFailed "cmm" (ExitFailure 1)) - return (Just next_phase, maybe_loc, output_fn) + return (Just next_phase, dflags, maybe_loc, output_fn) ----------------------------------------------------------------------------- -- Cc phase @@ -672,9 +677,9 @@ runPhase Cmm basename suff input_fn get_output_fn maybe_loc -- we don't support preprocessing .c files (with -E) now. Doing so introduces -- way too many hacks, and I can't say I've ever used it anyway. -runPhase cc_phase basename suff input_fn get_output_fn maybe_loc +runPhase cc_phase dflags basename suff input_fn get_output_fn maybe_loc | cc_phase == Cc || cc_phase == HCc - = do cc_opts <- getOpts opt_c + = do let cc_opts = getOpts dflags opt_c cmdline_include_paths <- readIORef v_Include_paths split <- readIORef v_Split_object_files @@ -694,16 +699,16 @@ runPhase cc_phase basename suff input_fn get_output_fn maybe_loc -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) - pkg_include_dirs <- getPackageIncludePath pkgs + pkg_include_dirs <- getPackageIncludePath dflags pkgs let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) mangle <- readIORef v_Do_asm_mangling - (md_c_flags, md_regd_c_flags) <- machdepCCOpts + (md_c_flags, md_regd_c_flags) <- machdepCCOpts dflags - verb <- getVerbFlag + let verb = getVerbFlag dflags - pkg_extra_cc_opts <- getPackageExtraCcOpts pkgs + pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs split_objs <- readIORef v_Split_object_files let split_opt | hcc && split_objs = [ "-DUSE_SPLIT_MARKERS" ] @@ -717,7 +722,7 @@ runPhase cc_phase basename suff input_fn get_output_fn maybe_loc | cc_phase == HCc = [ SysTools.Option "-x", SysTools.Option "c"] | otherwise = [ ] - SysTools.runCc (langopt ++ + SysTools.runCc dflags (langopt ++ [ SysTools.FileOption "" input_fn , SysTools.Option "-o" , SysTools.FileOption "" output_fn @@ -736,17 +741,17 @@ runPhase cc_phase basename suff input_fn get_output_fn maybe_loc ++ pkg_extra_cc_opts )) - return (Just next_phase, maybe_loc, output_fn) + return (Just next_phase, dflags, maybe_loc, output_fn) -- ToDo: postprocess the output from gcc ----------------------------------------------------------------------------- -- Mangle phase -runPhase Mangle _basename _suff input_fn get_output_fn maybe_loc - = do mangler_opts <- getOpts opt_m +runPhase Mangle dflags _basename _suff input_fn get_output_fn maybe_loc + = do let mangler_opts = getOpts dflags opt_m machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM) - then do n_regs <- dynFlag stolen_x86_regs + then do let n_regs = stolen_x86_regs dflags return [ show n_regs ] else return [] @@ -756,24 +761,25 @@ runPhase Mangle _basename _suff input_fn get_output_fn maybe_loc | otherwise = As output_fn <- get_output_fn next_phase maybe_loc - SysTools.runMangle (map SysTools.Option mangler_opts + SysTools.runMangle dflags (map SysTools.Option mangler_opts ++ [ SysTools.FileOption "" input_fn , SysTools.FileOption "" output_fn ] ++ map SysTools.Option machdep_opts) - return (Just next_phase, maybe_loc, output_fn) + return (Just next_phase, dflags, maybe_loc, output_fn) ----------------------------------------------------------------------------- -- Splitting phase -runPhase SplitMangle _basename _suff input_fn get_output_fn maybe_loc +runPhase SplitMangle dflags _basename _suff input_fn get_output_fn maybe_loc = do -- tmp_pfx is the prefix used for the split .s files -- We also use it as the file to contain the no. of split .s files (sigh) split_s_prefix <- SysTools.newTempName "split" let n_files_fn = split_s_prefix - SysTools.runSplit [ SysTools.FileOption "" input_fn + SysTools.runSplit dflags + [ SysTools.FileOption "" input_fn , SysTools.FileOption "" split_s_prefix , SysTools.FileOption "" n_files_fn ] @@ -787,14 +793,14 @@ runPhase SplitMangle _basename _suff input_fn get_output_fn maybe_loc addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s" | n <- [1..n_files]] - return (Just SplitAs, maybe_loc, "**splitmangle**") + return (Just SplitAs, dflags, maybe_loc, "**splitmangle**") -- we don't use the filename ----------------------------------------------------------------------------- -- As phase -runPhase As _basename _suff input_fn get_output_fn maybe_loc - = do as_opts <- getOpts opt_a +runPhase As dflags _basename _suff input_fn get_output_fn maybe_loc + = do let as_opts = getOpts dflags opt_a cmdline_include_paths <- readIORef v_Include_paths output_fn <- get_output_fn Ln maybe_loc @@ -803,7 +809,8 @@ runPhase As _basename _suff input_fn get_output_fn maybe_loc -- might be a hierarchical module. createDirectoryHierarchy (directoryOf output_fn) - SysTools.runAs (map SysTools.Option as_opts + SysTools.runAs dflags + (map SysTools.Option as_opts ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] ++ [ SysTools.Option "-c" , SysTools.FileOption "" input_fn @@ -811,11 +818,11 @@ runPhase As _basename _suff input_fn get_output_fn maybe_loc , SysTools.FileOption "" output_fn ]) - return (Just Ln, maybe_loc, output_fn) + return (Just Ln, dflags, maybe_loc, output_fn) -runPhase SplitAs basename _suff _input_fn get_output_fn maybe_loc - = do as_opts <- getOpts opt_a +runPhase SplitAs dflags basename _suff _input_fn get_output_fn maybe_loc + = do let as_opts = getOpts dflags opt_a (split_s_prefix, n) <- readIORef v_Split_info @@ -830,7 +837,8 @@ runPhase SplitAs basename _suff _input_fn get_output_fn maybe_loc (basename ++ "__" ++ show n ++ ".o") real_odir real_o <- osuf_ify output_o - SysTools.runAs (map SysTools.Option as_opts ++ + SysTools.runAs dflags + (map SysTools.Option as_opts ++ [ SysTools.Option "-c" , SysTools.Option "-o" , SysTools.FileOption "" real_o @@ -840,15 +848,15 @@ runPhase SplitAs basename _suff _input_fn get_output_fn maybe_loc mapM_ assemble_file [1..n] output_fn <- get_output_fn Ln maybe_loc - return (Just Ln, maybe_loc, output_fn) + return (Just Ln, dflags, maybe_loc, output_fn) #ifdef ILX ----------------------------------------------------------------------------- -- Ilx2Il phase -- Run ilx2il over the ILX output, getting an IL file -runPhase Ilx2Il _basename _suff input_fn get_output_fn maybe_loc - = do ilx2il_opts <- getOpts opt_I +runPhase Ilx2Il dflags _basename _suff input_fn get_output_fn maybe_loc + = do let ilx2il_opts = getOpts dflags opt_I SysTools.runIlx2il (map SysTools.Option ilx2il_opts ++ [ SysTools.Option "--no-add-suffix-to-assembly", SysTools.Option "mscorlib", @@ -861,8 +869,8 @@ runPhase Ilx2Il _basename _suff input_fn get_output_fn maybe_loc -- Ilasm phase -- Run ilasm over the IL, getting a DLL -runPhase Ilasm _basename _suff input_fn get_output_fn maybe_loc - = do ilasm_opts <- getOpts opt_i +runPhase Ilasm dflags _basename _suff input_fn get_output_fn maybe_loc + = do let ilasm_opts = getOpts dflags opt_i SysTools.runIlasm (map SysTools.Option ilasm_opts ++ [ SysTools.Option "/QUIET", SysTools.Option "/DLL", @@ -959,9 +967,9 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $ ----------------------------------------------------------------------------- -- Complain about non-dynamic flags in OPTIONS pragmas -checkProcessArgsResult flags basename suff +checkProcessArgsResult flags filename = do when (notNull flags) (throwDyn (ProgramError ( - showSDoc (hang (text basename <> text ('.':suff) <> char ':') + showSDoc (hang (text filename <> char ':') 4 (text "unknown flags in {-# OPTIONS #-} pragma:" <+> hsep (map text flags))) ))) @@ -969,13 +977,13 @@ checkProcessArgsResult flags basename suff ----------------------------------------------------------------------------- -- Look for the /* GHC_PACKAGES ... */ comment at the top of a .hc file -getHCFilePackages :: FilePath -> IO [PackageName] +getHCFilePackages :: FilePath -> IO [PackageId] getHCFilePackages filename = EXCEPTION.bracket (openFile filename ReadMode) hClose $ \h -> do l <- hGetLine h case l of '/':'*':' ':'G':'H':'C':'_':'P':'A':'C':'K':'A':'G':'E':'S':rest -> - return (map mkPackageName (words rest)) + return (map stringToPackageId (words rest)) _other -> return [] @@ -992,9 +1000,9 @@ getHCFilePackages filename = -- read any interface files), so the user must explicitly specify all -- the packages. -staticLink :: [FilePath] -> [PackageName] -> IO () -staticLink o_files dep_packages = do - verb <- getVerbFlag +staticLink :: DynFlags -> [FilePath] -> [PackageId] -> IO () +staticLink dflags o_files dep_packages = do + let verb = getVerbFlag dflags static <- readIORef v_Static no_hs_main <- readIORef v_NoHsMain @@ -1009,22 +1017,22 @@ staticLink o_files dep_packages = do let output_fn = case o_file of { Just s -> s; Nothing -> "a.out"; } #endif - pkg_lib_paths <- getPackageLibraryPath dep_packages + pkg_lib_paths <- getPackageLibraryPath dflags dep_packages let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths lib_paths <- readIORef v_Library_paths let lib_path_opts = map ("-L"++) lib_paths - pkg_link_opts <- getPackageLinkOpts dep_packages + pkg_link_opts <- getPackageLinkOpts dflags dep_packages #ifdef darwin_TARGET_OS - pkg_framework_paths <- getPackageFrameworkPath dep_packages + pkg_framework_paths <- getPackageFrameworkPath dflags dep_packages let pkg_framework_path_opts = map ("-F"++) pkg_framework_paths framework_paths <- readIORef v_Framework_paths let framework_path_opts = map ("-F"++) framework_paths - pkg_frameworks <- getPackageFrameworks dep_packages + pkg_frameworks <- getPackageFrameworks dflags dep_packages let pkg_framework_opts = concat [ ["-framework", fw] | fw <- pkg_frameworks ] frameworks <- readIORef v_Cmdline_frameworks @@ -1038,7 +1046,13 @@ staticLink o_files dep_packages = do -- opts from -optl-<blah> (including -l<blah> options) extra_ld_opts <- getStaticOpts v_Opt_l - [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage] + let pstate = pkgState dflags + rts_id | Just id <- rtsPackageId pstate = id + | otherwise = panic "staticLink: rts package missing" + base_id | Just id <- basePackageId pstate = id + | otherwise = panic "staticLink: base package missing" + rts_pkg = getPackageDetails pstate rts_id + base_pkg = getPackageDetails pstate base_id ways <- readIORef v_Ways @@ -1067,10 +1081,11 @@ staticLink o_files dep_packages = do let extra_os = if static || no_hs_main then [] else [ head (libraryDirs rts_pkg) ++ "/Main.dll_o", - head (libraryDirs std_pkg) ++ "/PrelMain.dll_o" ] + head (libraryDirs base_pkg) ++ "/PrelMain.dll_o" ] - (md_c_flags, _) <- machdepCCOpts - SysTools.runLink ( [ SysTools.Option verb + (md_c_flags, _) <- machdepCCOpts dflags + SysTools.runLink dflags ( + [ SysTools.Option verb , SysTools.Option "-o" , SysTools.FileOption "" output_fn ] @@ -1105,22 +1120,22 @@ staticLink o_files dep_packages = do ----------------------------------------------------------------------------- -- Making a DLL (only for Win32) -doMkDLL :: [String] -> [PackageName] -> IO () -doMkDLL o_files dep_packages = do - verb <- getVerbFlag +doMkDLL :: DynFlags -> [String] -> [PackageId] -> IO () +doMkDLL dflags o_files dep_packages = do + let verb = getVerbFlag dflags static <- readIORef v_Static no_hs_main <- readIORef v_NoHsMain o_file <- readIORef v_Output_file let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } - pkg_lib_paths <- getPackageLibraryPath dep_packages + pkg_lib_paths <- getPackageLibraryPath dflags dep_packages let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths lib_paths <- readIORef v_Library_paths let lib_path_opts = map ("-L"++) lib_paths - pkg_link_opts <- getPackageLinkOpts dep_packages + pkg_link_opts <- getPackageLinkOpts dflags dep_packages -- probably _stub.o files extra_ld_inputs <- readIORef v_Ld_inputs @@ -1128,15 +1143,21 @@ doMkDLL o_files dep_packages = do -- opts from -optdll-<blah> extra_ld_opts <- getStaticOpts v_Opt_dll - [rts_pkg, std_pkg] <- getPackageDetails [rtsPackage, basePackage] + let pstate = pkgState dflags + rts_id | Just id <- rtsPackageId pstate = id + | otherwise = panic "staticLink: rts package missing" + base_id | Just id <- basePackageId pstate = id + | otherwise = panic "staticLink: base package missing" + rts_pkg = getPackageDetails pstate rts_id + base_pkg = getPackageDetails pstate base_id let extra_os = if static || no_hs_main then [] else [ head (libraryDirs rts_pkg) ++ "/Main.dll_o", - head (libraryDirs std_pkg) ++ "/PrelMain.dll_o" ] + head (libraryDirs base_pkg) ++ "/PrelMain.dll_o" ] - (md_c_flags, _) <- machdepCCOpts - SysTools.runMkDLL + (md_c_flags, _) <- machdepCCOpts dflags + SysTools.runMkDLL dflags ([ SysTools.Option verb , SysTools.Option "-o" , SysTools.FileOption "" output_fn @@ -1159,26 +1180,26 @@ doMkDLL o_files dep_packages = do -- ----------------------------------------------------------------------------- -- Misc. -doCpp :: Bool -> Bool -> FilePath -> FilePath -> IO () -doCpp raw include_cc_opts input_fn output_fn = do - hscpp_opts <- getOpts opt_P +doCpp :: DynFlags -> Bool -> Bool -> FilePath -> FilePath -> IO () +doCpp dflags raw include_cc_opts input_fn output_fn = do + let hscpp_opts = getOpts dflags opt_P cmdline_include_paths <- readIORef v_Include_paths - pkg_include_dirs <- getPackageIncludePath [] + pkg_include_dirs <- getPackageIncludePath dflags [] let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) - verb <- getVerbFlag + let verb = getVerbFlag dflags cc_opts <- if not include_cc_opts then return [] - else do optc <- getOpts opt_c - (md_c_flags, _) <- machdepCCOpts + else do let optc = getOpts dflags opt_c + (md_c_flags, _) <- machdepCCOpts dflags return (optc ++ md_c_flags) - let cpp_prog args | raw = SysTools.runCpp args - | otherwise = SysTools.runCc (SysTools.Option "-E" : args) + let cpp_prog args | raw = SysTools.runCpp dflags args + | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) let target_defs = [ "-D" ++ cTARGETOS ++ "_TARGET_OS=1", diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs index f92f295669..23c7cbb42c 100644 --- a/ghc/compiler/main/DriverState.hs +++ b/ghc/compiler/main/DriverState.hs @@ -11,13 +11,9 @@ module DriverState where #include "../includes/ghcconfig.h" #include "HsVersions.h" -import ParsePkgConf ( loadPackageConfig ) -import SysTools ( getTopDir ) -import Packages import CmdLineOpts import DriverPhases import DriverUtil -import UniqFM ( eltsUFM ) import Util import Config import Panic @@ -200,8 +196,7 @@ buildStgToDo = do split_marker = ':' -- not configurable (ToDo) -v_Import_paths, v_Include_paths, v_Library_paths :: IORef [String] -GLOBAL_VAR(v_Import_paths, ["."], [String]) +v_Include_paths, v_Library_paths :: IORef [String] GLOBAL_VAR(v_Include_paths, [], [String]) GLOBAL_VAR(v_Library_paths, [], [String]) @@ -280,189 +275,6 @@ addToDirList ref path splitUp xs = return (split split_marker xs) #endif --- ---------------------------------------------------------------------------- --- Loading the package config file - -readPackageConf :: String -> IO () -readPackageConf conf_file = do - proto_pkg_configs <- loadPackageConfig conf_file - top_dir <- getTopDir - let pkg_configs = mungePackagePaths top_dir proto_pkg_configs - extendPackageConfigMap pkg_configs - -mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig] --- Replace the string "$libdir" at the beginning of a path --- with the current libdir (obtained from the -B option). -mungePackagePaths top_dir ps = map munge_pkg ps - where - munge_pkg p = p{ importDirs = munge_paths (importDirs p), - includeDirs = munge_paths (includeDirs p), - libraryDirs = munge_paths (libraryDirs p), - frameworkDirs = munge_paths (frameworkDirs p) } - - munge_paths = map munge_path - - munge_path p - | Just p' <- maybePrefixMatch "$libdir" p = top_dir ++ p' - | otherwise = p - - --- ----------------------------------------------------------------------------- --- The list of packages requested on the command line - --- The package list reflects what packages were given as command-line options, --- plus their dependent packages. It is maintained in dependency order; --- earlier packages may depend on later ones, but not vice versa -GLOBAL_VAR(v_ExplicitPackages, initPackageList, [PackageName]) - -initPackageList = [basePackage, rtsPackage] - -- basePackage is part of this list entirely because of - -- wired-in names in GHCi. See the notes on wired-in names in - -- Linker.linkExpr. By putting the base backage in initPackageList - -- we make sure that it'll always by linked. - - --- add a package requested from the command-line -addPackage :: String -> IO () -addPackage package = do - pkg_details <- getPackageConfigMap - ps <- readIORef v_ExplicitPackages - ps' <- add_package pkg_details ps (mkPackageName package) - -- Throws an exception if it fails - writeIORef v_ExplicitPackages ps' - --- internal helper -add_package :: PackageConfigMap -> [PackageName] - -> PackageName -> IO [PackageName] -add_package pkg_details ps p - | p `elem` ps -- Check if we've already added this package - = return ps - | Just details <- lookupPkg pkg_details p - -- Add the package's dependents also - = do ps' <- foldM (add_package pkg_details) ps (packageDependents details) - return (p : ps') - | otherwise - = throwDyn (CmdLineError ("unknown package name: " ++ packageNameString p)) - - --- ----------------------------------------------------------------------------- --- Extracting information from the packages in scope - --- Many of these functions take a list of packages: in those cases, --- the list is expected to contain the "dependent packages", --- i.e. those packages that were found to be depended on by the --- current module/program. These can be auto or non-auto packages, it --- doesn't really matter. The list is always combined with the list --- of explicit (command-line) packages to determine which packages to --- use. - -getPackageImportPath :: IO [String] -getPackageImportPath = do - ps <- getExplicitAndAutoPackageConfigs - -- import dirs are always derived from the 'auto' - -- packages as well as the explicit ones - return (nub (filter notNull (concatMap importDirs ps))) - -getPackageIncludePath :: [PackageName] -> IO [String] -getPackageIncludePath pkgs = do - ps <- getExplicitPackagesAnd pkgs - return (nub (filter notNull (concatMap includeDirs ps))) - - -- includes are in reverse dependency order (i.e. rts first) -getPackageCIncludes :: [PackageConfig] -> IO [String] -getPackageCIncludes pkg_configs = do - return (reverse (nub (filter notNull (concatMap includes pkg_configs)))) - -getPackageLibraryPath :: [PackageName] -> IO [String] -getPackageLibraryPath pkgs = do - ps <- getExplicitPackagesAnd pkgs - return (nub (filter notNull (concatMap libraryDirs ps))) - -getPackageLinkOpts :: [PackageName] -> IO [String] -getPackageLinkOpts pkgs = do - ps <- getExplicitPackagesAnd pkgs - tag <- readIORef v_Build_tag - rts_tag <- readIORef v_RTS_Build_tag - static <- readIORef v_Static - let - imp = if static then "" else "_imp" - libs p = map addSuffix (hACK (hsLibraries p)) ++ extraLibraries p - imp_libs p = map (++imp) (libs p) - all_opts p = map ("-l" ++) (imp_libs p) ++ extraLdOpts p - - suffix = if null tag then "" else '_':tag - rts_suffix = if null rts_tag then "" else '_':rts_tag - - addSuffix rts@"HSrts" = rts ++ rts_suffix - addSuffix other_lib = other_lib ++ suffix - - return (concat (map all_opts ps)) - where - - -- This is a totally horrible (temporary) hack, for Win32. Problem is - -- that package.conf for Win32 says that the main prelude lib is - -- split into HSbase1, HSbase2 and HSbase3, which is needed due to a bug - -- in the GNU linker (PEi386 backend). However, we still only - -- have HSbase.a for static linking, not HSbase{1,2,3}.a - -- getPackageLibraries is called to find the .a's to add to the static - -- link line. On Win32, this hACK detects HSbase{1,2,3} and - -- replaces them with HSbase, so static linking still works. - -- Libraries needed for dynamic (GHCi) linking are discovered via - -- different route (in InteractiveUI.linkPackage). - -- See driver/PackageSrc.hs for the HSbase1/HSbase2 split definition. - -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...) - -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2] - -- KAA 29 Mar 02: Same appalling hack for HSobjectio[1,2,3,4] - hACK libs -# if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS) - = libs -# else - = if "HSbase1" `elem` libs && "HSbase2" `elem` libs && "HSbase3" `elem` libs - then "HSbase" : filter (not.(isPrefixOf "HSbase")) libs - else - if "HSwin321" `elem` libs && "HSwin322" `elem` libs - then "HSwin32" : filter (not.(isPrefixOf "HSwin32")) libs - else - if "HSobjectio1" `elem` libs && "HSobjectio2" `elem` libs && "HSobjectio3" `elem` libs && "HSobjectio4" `elem` libs - then "HSobjectio" : filter (not.(isPrefixOf "HSobjectio")) libs - else - libs -# endif - -getPackageExtraCcOpts :: [PackageName] -> IO [String] -getPackageExtraCcOpts pkgs = do - ps <- getExplicitPackagesAnd pkgs - return (concatMap extraCcOpts ps) - -#ifdef darwin_TARGET_OS -getPackageFrameworkPath :: [PackageName] -> IO [String] -getPackageFrameworkPath pkgs = do - ps <- getExplicitPackagesAnd pkgs - return (nub (filter notNull (concatMap frameworkDirs ps))) - -getPackageFrameworks :: [PackageName] -> IO [String] -getPackageFrameworks pkgs = do - ps <- getExplicitPackagesAnd pkgs - return (concatMap extraFrameworks ps) -#endif - --- ----------------------------------------------------------------------------- --- Package Utils - -getExplicitPackagesAnd :: [PackageName] -> IO [PackageConfig] -getExplicitPackagesAnd pkg_names = do - pkg_map <- getPackageConfigMap - expl <- readIORef v_ExplicitPackages - all_pkgs <- foldM (add_package pkg_map) expl pkg_names - getPackageDetails all_pkgs - --- return all packages, including both the auto packages and the explicit ones -getExplicitAndAutoPackageConfigs :: IO [PackageConfig] -getExplicitAndAutoPackageConfigs = do - pkg_map <- getPackageConfigMap - let auto_packages = [ packageConfigName p | p <- eltsUFM pkg_map, exposed p ] - getExplicitPackagesAnd auto_packages - ----------------------------------------------------------------------------- -- Ways diff --git a/ghc/compiler/main/Finder.lhs b/ghc/compiler/main/Finder.lhs index 24936ec27e..c255408fac 100644 --- a/ghc/compiler/main/Finder.lhs +++ b/ghc/compiler/main/Finder.lhs @@ -6,15 +6,10 @@ \begin{code} module Finder ( flushFinderCache, -- :: IO () - - findModule, -- :: ModuleName - -- -> IO (Either [FilePath] (Module, ModLocation)) - - findPackageModule, -- :: ModuleName - -- -> IO (Either [FilePath] (Module, ModLocation)) - + FindResult(..), + findModule, -- :: ModuleName -> Bool -> IO FindResult + findPackageModule, -- :: ModuleName -> Bool -> IO FindResult mkHomeModLocation, -- :: ModuleName -> FilePath -> IO ModLocation - findLinkable, -- :: ModuleName -> ModLocation -> IO (Maybe Linkable) hiBootExt, -- :: String @@ -26,53 +21,56 @@ module Finder ( import Module import UniqFM ( filterUFM ) -import HscTypes ( Linkable(..), Unlinked(..) ) +import HscTypes ( Linkable(..), Unlinked(..), IfacePackage(..) ) +import Packages import DriverState import DriverUtil import FastString import Config import Util +import CmdLineOpts ( DynFlags(..) ) import DATA_IOREF ( IORef, writeIORef, readIORef ) -import List -import Directory -import IO -import Monad +import Data.List +import System.Directory +import System.IO +import Control.Monad +import Data.Maybe ( isNothing ) -- ----------------------------------------------------------------------------- -- The Finder --- The Finder provides a thin filesystem abstraction to the rest of the --- compiler. For a given module, it knows (a) whether the module lives --- in the home package or in another package, so it can make a Module --- from a ModuleName, and (b) where the source, interface, and object --- files for a module live. +-- The Finder provides a thin filesystem abstraction to the rest of +-- the compiler. For a given module, it can tell you where the +-- source, interface, and object files for that module live. -- --- It does *not* know which particular package a module lives in, because --- that information is only contained in the interface file. +-- It does *not* know which particular package a module lives in. Use +-- Packages.moduleToPackageConfig for that. -- ----------------------------------------------------------------------------- -- The finder's cache -GLOBAL_VAR(finder_cache, emptyModuleEnv, ModuleEnv (Module,ModLocation)) +GLOBAL_VAR(finder_cache, emptyModuleEnv, ModuleEnv FinderCacheEntry) + +type FinderCacheEntry = (ModLocation,Maybe (PackageConfig,Bool)) -- remove all the home modules from the cache; package modules are -- assumed to not move around during a session. flushFinderCache :: IO () flushFinderCache = do fm <- readIORef finder_cache - writeIORef finder_cache (filterUFM (not . isHomeModule . fst) fm) + writeIORef finder_cache (filterUFM (\(loc,m) -> isNothing m) fm) -addToFinderCache :: ModuleName -> (Module,ModLocation) -> IO () -addToFinderCache mod_name stuff = do +addToFinderCache :: Module -> FinderCacheEntry -> IO () +addToFinderCache mod_name entry = do fm <- readIORef finder_cache - writeIORef finder_cache (extendModuleEnvByName fm mod_name stuff) + writeIORef finder_cache (extendModuleEnv fm mod_name entry) -lookupFinderCache :: ModuleName -> IO (Maybe (Module,ModLocation)) +lookupFinderCache :: Module -> IO (Maybe FinderCacheEntry) lookupFinderCache mod_name = do fm <- readIORef finder_cache - return $! lookupModuleEnvByName fm mod_name + return $! lookupModuleEnv fm mod_name -- ----------------------------------------------------------------------------- -- Locating modules @@ -87,52 +85,81 @@ lookupFinderCache mod_name = do -- The ModLocation contains the names of all the files associated with -- that module: its source file, .hi file, object file, etc. --- Returns: --- Right (Module, ModLocation) if the module was found --- Left [FilePath] if the module was not found, and here --- is a list of all the places we looked -findModule :: ModuleName -> IO (Either [FilePath] (Module, ModLocation)) -findModule name = do - r <- lookupFinderCache name - case r of - Just result -> return (Right result) - Nothing -> do - j <- maybeHomeModule name - case j of - Right home_module -> return (Right home_module) - Left home_files -> do - r <- findPackageMod name +data FindResult + = Found ModLocation IfacePackage + -- the module was found + | 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 :: DynFlags -> Module -> Bool -> IO FindResult +findModule = cached findModule' + +findModule' :: DynFlags -> Module -> Bool -> IO FindResult +findModule' dflags name explicit = do + j <- maybeHomeModule dflags name + case j of + NotFound home_files -> do + r <- findPackageModule' dflags name explicit case r of - Right pkg_module -> return (Right pkg_module) - Left pkg_files -> return (Left (home_files ++ pkg_files)) - -findPackageModule :: ModuleName -> IO (Either [FilePath] (Module, ModLocation)) -findPackageModule name = do - r <- lookupFinderCache name - case r of - Just result -> return (Right result) - Nothing -> findPackageMod name + NotFound pkg_files + -> return (NotFound (home_files ++ pkg_files)) + other_result + -> return other_result + other_result -> return other_result + +cached fn dflags name explicit = do + m <- lookupFinderCache name + case m of + Nothing -> fn dflags name explicit + Just (loc,maybe_pkg) + | Just err <- visible explicit maybe_pkg -> return err + | otherwise -> return (Found loc (pkgInfoToId maybe_pkg)) + +pkgInfoToId :: Maybe (PackageConfig,Bool) -> IfacePackage +pkgInfoToId (Just (pkg,_)) = ExternalPackage (mkPackageId (package pkg)) +pkgInfoToId Nothing = ThisPackage + +-- Is a module visible or not? Returns Nothing if the import is ok, +-- or Just err if there's a visibility error. +visible :: Bool -> Maybe (PackageConfig,Bool) -> Maybe FindResult +visible explicit maybe_pkg + | Nothing <- maybe_pkg = Nothing -- home module ==> YES + | not explicit = Nothing -- implicit import ==> YES + | Just (pkg, exposed_module) <- maybe_pkg + = case () of + _ | not exposed_module -> Just (ModuleHidden pkgname) + | not (exposed pkg) -> Just (PackageHidden pkgname) + | otherwise -> Nothing + where + pkgname = packageConfigId pkg + hiBootExt = "hi-boot" hiBootVerExt = "hi-boot-" ++ cHscIfaceFileVersion -maybeHomeModule :: ModuleName -> IO (Either [FilePath] (Module, ModLocation)) -maybeHomeModule mod_name = do - home_path <- readIORef v_Import_paths +maybeHomeModule :: DynFlags -> Module -> IO FindResult +maybeHomeModule dflags mod = do + let home_path = importPaths dflags hisuf <- readIORef v_Hi_suf mode <- readIORef v_GhcMode let source_exts = - [ ("hs", mkHomeModLocationSearched mod_name) - , ("lhs", mkHomeModLocationSearched mod_name) + [ ("hs", mkHomeModLocationSearched mod) + , ("lhs", mkHomeModLocationSearched mod) ] - hi_exts = [ (hisuf, mkHiOnlyModLocation hisuf mod_name) ] + hi_exts = [ (hisuf, mkHiOnlyModLocation hisuf mod) ] boot_exts = - [ (hiBootVerExt, mkHiOnlyModLocation hisuf mod_name) - , (hiBootExt, mkHiOnlyModLocation hisuf mod_name) + [ (hiBootVerExt, mkHiOnlyModLocation hisuf mod) + , (hiBootExt, mkHiOnlyModLocation hisuf mod) ] -- In compilation manager modes, we look for source files in the home @@ -146,16 +173,33 @@ maybeHomeModule mod_name = do | isCompManagerMode mode = source_exts | otherwise {-one-shot-} = hi_exts ++ boot_exts - searchPathExts home_path mod_name exts + searchPathExts home_path mod exts -- ----------------------------------------------------------------------------- -- Looking for a package module -findPackageMod :: ModuleName -> IO (Either [FilePath] (Module, ModLocation)) -findPackageMod mod_name = do +findPackageModule :: DynFlags -> Module -> Bool -> IO FindResult +findPackageModule = cached findPackageModule' + +findPackageModule' :: DynFlags -> Module -> Bool -> IO FindResult +findPackageModule' dflags mod explicit = do mode <- readIORef v_GhcMode - imp_dirs <- getPackageImportPath -- including the 'auto' ones + case moduleToPackageConfig dflags mod of + Nothing -> return (NotFound []) + pkg_info@(Just (pkg_conf, module_exposed)) + | Just err <- visible explicit pkg_info -> return err + | otherwise -> findPackageIface mode mod paths pkg_info + where + paths = importDirs pkg_conf + +findPackageIface + :: GhcMode + -> Module + -> [FilePath] + -> Maybe (PackageConfig,Bool) + -> IO FindResult +findPackageIface mode mod imp_dirs pkg_info = do -- hi-suffix for packages depends on the build tag. package_hisuf <- do tag <- readIORef v_Build_tag @@ -165,13 +209,14 @@ findPackageMod mod_name = do let hi_exts = - [ (package_hisuf, mkPackageModLocation package_hisuf mod_name) ] + [ (package_hisuf, + mkPackageModLocation pkg_info package_hisuf mod) ] source_exts = - [ ("hs", mkPackageModLocation package_hisuf mod_name) - , ("lhs", mkPackageModLocation package_hisuf mod_name) + [ ("hs", mkPackageModLocation pkg_info package_hisuf mod) + , ("lhs", mkPackageModLocation pkg_info package_hisuf mod) ] - + -- mkdependHS needs to look for source files in packages too, so -- that we can make dependencies between package before they have -- been built. @@ -181,26 +226,26 @@ findPackageMod mod_name = do -- we never look for a .hi-boot file in an external package; -- .hi-boot files only make sense for the home package. - searchPathExts imp_dirs mod_name exts + searchPathExts imp_dirs mod exts -- ----------------------------------------------------------------------------- -- General path searching searchPathExts :: [FilePath] -- paths to search - -> ModuleName -- module name + -> Module -- module name -> [ ( - String, -- suffix - String -> String -> String -> IO (Module, ModLocation) -- action + String, -- suffix + String -> String -> String -> IO FindResult -- action ) ] - -> IO (Either [FilePath] (Module, ModLocation)) + -> IO FindResult -searchPathExts path mod_name exts = search to_search +searchPathExts path mod exts = search to_search where - basename = dots_to_slashes (moduleNameUserString mod_name) + basename = dots_to_slashes (moduleUserString mod) - to_search :: [(FilePath, IO (Module,ModLocation))] + to_search :: [(FilePath, IO FindResult)] to_search = [ (file, fn p basename ext) | p <- path, (ext,fn) <- exts, @@ -209,29 +254,27 @@ searchPathExts path mod_name exts = search to_search file = base ++ '.':ext ] - search [] = return (Left (map fst to_search)) + search [] = return (NotFound (map fst to_search)) search ((file, result) : rest) = do b <- doesFileExist file if b - then Right `liftM` result + then result else search rest -- ----------------------------------------------------------------------------- -- Building ModLocations -mkHiOnlyModLocation hisuf mod_name path basename _ext = do - -- basename == dots_to_slashes (moduleNameUserString mod_name) +mkHiOnlyModLocation hisuf mod path basename _ext = do + -- basename == dots_to_slashes (moduleNameUserString mod) loc <- hiOnlyModLocation path basename hisuf - let result = (mkHomeModule mod_name, loc) - addToFinderCache mod_name result - return result + addToFinderCache mod (loc, Nothing) + return (Found loc ThisPackage) -mkPackageModLocation hisuf mod_name path basename _ext = do - -- basename == dots_to_slashes (moduleNameUserString mod_name) +mkPackageModLocation pkg_info hisuf mod path basename _ext = do + -- basename == dots_to_slashes (moduleNameUserString mod) loc <- hiOnlyModLocation path basename hisuf - let result = (mkPackageModule mod_name, loc) - addToFinderCache mod_name result - return result + addToFinderCache mod (loc, pkg_info) + return (Found loc (pkgInfoToId pkg_info)) hiOnlyModLocation path basename hisuf = do let full_basename = path++'/':basename @@ -265,7 +308,7 @@ hiOnlyModLocation path basename hisuf -- -- Parameters are: -- --- mod_name +-- mod -- The name of the module -- -- path @@ -273,34 +316,33 @@ hiOnlyModLocation path basename hisuf -- (b) and (c): "." -- -- src_basename --- (a): dots_to_slashes (moduleNameUserString mod_name) +-- (a): dots_to_slashes (moduleNameUserString mod) -- (b) and (c): The filename of the source file, minus its extension -- -- ext -- The filename extension of the source file (usually "hs" or "lhs"). -mkHomeModLocation mod_name src_filename = do +mkHomeModLocation mod src_filename = do let (basename,extension) = splitFilename src_filename - mkHomeModLocation' mod_name basename extension + mkHomeModLocation' mod basename extension -mkHomeModLocationSearched mod_name path basename ext = - mkHomeModLocation' mod_name (path ++ '/':basename) ext +mkHomeModLocationSearched mod path basename ext = do + loc <- mkHomeModLocation' mod (path ++ '/':basename) ext + return (Found loc ThisPackage) -mkHomeModLocation' mod_name src_basename ext = do - let mod_basename = dots_to_slashes (moduleNameUserString mod_name) +mkHomeModLocation' mod src_basename ext = do + let mod_basename = dots_to_slashes (moduleUserString mod) obj_fn <- mkObjPath src_basename mod_basename hi_fn <- mkHiPath src_basename mod_basename - let result = ( mkHomeModule mod_name, - ModLocation{ ml_hspp_file = Nothing, - ml_hs_file = Just (src_basename ++ '.':ext), - ml_hi_file = hi_fn, - ml_obj_file = obj_fn - }) + let loc = ModLocation{ ml_hspp_file = Nothing, + ml_hs_file = Just (src_basename ++ '.':ext), + ml_hi_file = hi_fn, + ml_obj_file = obj_fn } - addToFinderCache mod_name result - return result + addToFinderCache mod (loc, Nothing) + return loc -- | Constructs the filename of a .o file for a given source file. -- Does /not/ check whether the .o file exists @@ -336,7 +378,7 @@ mkHiPath basename mod_basename -- findLinkable isn't related to the other stuff in here, -- but there's no other obvious place for it -findLinkable :: ModuleName -> ModLocation -> IO (Maybe Linkable) +findLinkable :: Module -> ModLocation -> IO (Maybe Linkable) findLinkable mod locn = do let obj_fn = ml_obj_file locn obj_exist <- doesFileExist obj_fn diff --git a/ghc/compiler/main/GetImports.hs b/ghc/compiler/main/GetImports.hs index 57ded51da4..249e1e14f1 100644 --- a/ghc/compiler/main/GetImports.hs +++ b/ghc/compiler/main/GetImports.hs @@ -1,5 +1,5 @@ ----------------------------------------------------------------------------- --- $Id: GetImports.hs,v 1.10 2002/09/13 15:02:34 simonpj Exp $ +-- $Id: GetImports.hs,v 1.11 2004/11/26 16:20:57 simonmar Exp $ -- -- GHC Driver program -- @@ -18,7 +18,7 @@ import Char -- getImportsFromFile is careful to close the file afterwards, otherwise -- we can end up with a large number of open handles before the garbage -- collector gets around to closing them. -getImportsFromFile :: String -> IO ([ModuleName], [ModuleName], ModuleName) +getImportsFromFile :: String -> IO ([Module], [Module], Module) getImportsFromFile filename = do hdl <- openFile filename ReadMode modsrc <- hGetContents hdl @@ -27,11 +27,11 @@ getImportsFromFile filename hClose hdl return (srcimps,imps,mod_name) -getImports :: String -> ([ModuleName], [ModuleName], ModuleName) +getImports :: String -> ([Module], [Module], Module) getImports s = case f [{-accum source imports-}] [{-accum normal imports-}] Nothing (clean s) of - (si, ni, Nothing) -> (si, ni, mkModuleName "Main") + (si, ni, Nothing) -> (si, ni, mkModule "Main") (si, ni, Just me) -> (si, ni, me) where -- Only pick up the name following 'module' the first time. @@ -59,7 +59,7 @@ getImports s f si ni me (w:ws) = f si ni me ws f si ni me [] = (nub si, nub ni, me) - mkMN str = mkModuleName (takeWhile isModId (reverse str)) + mkMN str = mkModule (takeWhile isModId (reverse str)) isModId c = isAlphaNum c || c `elem` "'._" diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index bcb967ff9a..3ce9eb9c94 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -15,14 +15,13 @@ module HscTypes ( ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, - lookupIface, lookupIfaceByModName, moduleNameToModule, - emptyModIface, + lookupIface, lookupIfaceByModule, emptyModIface, InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, unQualInScope, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, - emptyIfaceDepCache, + IfacePackage(..), emptyIfaceDepCache, Deprecs(..), IfaceDeprecs, @@ -64,7 +63,7 @@ import ByteCodeAsm ( CompiledByteCode ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv, GlobalRdrElt(..), mkRdrUnqual, lookupGRE_RdrName ) -import Name ( Name, NamedThing, getName, nameOccName, nameModule, nameModuleName ) +import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, @@ -79,7 +78,7 @@ import Type ( TyThing(..) ) import Class ( Class, classSelIds, classTyCon ) import TyCon ( TyCon, tyConSelIds, tyConDataCons ) import DataCon ( dataConImplicitIds ) -import Packages ( PackageName ) +import Packages ( PackageId ) import CmdLineOpts ( DynFlags ) import BasicTypes ( Version, initialVersion, IPName, @@ -176,24 +175,14 @@ lookupIface hpt pit mod Just mod_info -> Just (hm_iface mod_info) Nothing -> lookupModuleEnv pit mod -lookupIfaceByModName :: HomePackageTable -> PackageIfaceTable -> ModuleName -> Maybe ModIface +lookupIfaceByModule :: HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface -- We often have two IfaceTables, and want to do a lookup -lookupIfaceByModName hpt pit mod - = case lookupModuleEnvByName hpt mod of +lookupIfaceByModule hpt pit mod + = case lookupModuleEnv hpt mod of Just mod_info -> Just (hm_iface mod_info) - Nothing -> lookupModuleEnvByName pit mod -\end{code} - -\begin{code} --- Use instead of Finder.findModule if possible: this way doesn't --- require filesystem operations, and it is guaranteed not to fail --- when the IfaceTables are properly populated (i.e. after the renamer). -moduleNameToModule :: HomePackageTable -> PackageIfaceTable -> ModuleName -> Module -moduleNameToModule hpt pit mod - = mi_module (fromJust (lookupIfaceByModName hpt pit mod)) + Nothing -> lookupModuleEnv pit mod \end{code} - %************************************************************************ %* * \subsection{Symbol tables and Module details} @@ -212,7 +201,7 @@ the declarations into a single indexed map in the @PersistentRenamerState@. \begin{code} data ModIface = ModIface { - mi_package :: !PackageName, -- Which package the module comes from + mi_package :: !IfacePackage, -- Which package the module comes from mi_module :: !Module, mi_mod_vers :: !Version, -- Module version: changes when anything changes @@ -266,6 +255,8 @@ data ModIface -- seeing if we are up to date wrt the old interface } +data IfacePackage = ThisPackage | ExternalPackage PackageId + -- Should be able to construct ModDetails from mi_decls in ModIface data ModDetails = ModDetails { @@ -348,10 +339,10 @@ data ForeignStubs = NoStubs \end{code} \begin{code} -emptyModIface :: PackageName -> ModuleName -> ModIface +emptyModIface :: IfacePackage -> Module -> ModIface emptyModIface pkg mod = ModIface { mi_package = pkg, - mi_module = mkModule pkg mod, + mi_module = mod, mi_mod_vers = initialVersion, mi_orphan = False, mi_boot = False, @@ -421,7 +412,7 @@ unQualInScope :: GlobalRdrEnv -> PrintUnqualified -- [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] -> nameModuleName (gre_name gre) == mod + [gre] -> nameModule (gre_name gre) == mod other -> False \end{code} @@ -585,7 +576,7 @@ data GenAvailInfo name = Avail name -- An ordinary identifier deriving( Eq ) -- Equality used when deciding if the interface has changed -type IfaceExport = (ModuleName, [GenAvailInfo OccName]) +type IfaceExport = (Module, [GenAvailInfo OccName]) availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldl add emptyNameSet avails @@ -662,9 +653,9 @@ type IsBootInterface = Bool -- Invariant: the dependencies of a module M never includes M -- Invariant: the lists are unordered, with no duplicates data Dependencies - = Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies - dep_pkgs :: [PackageName], -- External package dependencies - dep_orphs :: [ModuleName] } -- Orphan modules (whether home or external pkg) + = Deps { dep_mods :: [(Module,IsBootInterface)], -- Home-package module dependencies + dep_pkgs :: [PackageId], -- External package dependencies + dep_orphs :: [Module] } -- Orphan modules (whether home or external pkg) deriving( Eq ) -- Equality used only for old/new comparison in MkIface.addVersionInfo @@ -672,7 +663,7 @@ noDependencies :: Dependencies noDependencies = Deps [] [] [] data Usage - = Usage { usg_name :: ModuleName, -- Name of the module + = Usage { usg_name :: Module, -- 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 @@ -705,14 +696,14 @@ type PackageInstEnv = InstEnv data ExternalPackageState = EPS { - eps_is_boot :: !(ModuleEnv (ModuleName, IsBootInterface)), + 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 -- - -- The ModuleName part is not necessary, but it's useful for + -- The Module 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 @@ -785,8 +776,8 @@ type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) \end{code} \begin{code} -type Gated d = ([Name], (ModuleName, d)) -- The [Name] 'gate' the declaration; always non-empty - -- ModuleName records which iface file this +type Gated d = ([Name], (Module, d)) -- The [Name] 'gate' the declaration; always non-empty + -- Module records which iface file this -- decl came from type RulePool = [Gated IfaceRule] @@ -840,7 +831,7 @@ data Linkable = LM { linkableTime :: ClockTime, -- Time at which this linkable was built -- (i.e. when the bytecodes were produced, -- or the mod date on the files) - linkableModName :: ModuleName, -- Should be Module, but see below + linkableModule :: Module, -- Should be Module, but see below linkableUnlinked :: [Unlinked] } diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs index 91d60941a6..2c13c62866 100644 --- a/ghc/compiler/main/Main.hs +++ b/ghc/compiler/main/Main.hs @@ -1,7 +1,7 @@ {-# OPTIONS -fno-warn-incomplete-patterns -optc-DNON_POSIX_SOURCE #-} ----------------------------------------------------------------------------- --- $Id: Main.hs,v 1.140 2004/11/11 16:07:46 simonmar Exp $ +-- $Id: Main.hs,v 1.141 2004/11/26 16:21:00 simonmar Exp $ -- -- GHC Driver program -- @@ -25,31 +25,24 @@ import InteractiveUI( ghciWelcomeMsg, interactiveUI ) import CompManager ( cmInit, cmLoadModules, cmDepAnal ) import HscTypes ( GhciMode(..) ) import Config ( cBooterVersion, cGhcUnregisterised, cProjectVersion ) -import SysTools ( getPackageConfigPath, initSysTools, cleanTempFiles, - normalisePath ) -import Packages ( showPackages, getPackageConfigMap, basePackage, - haskell98Package - ) +import SysTools ( initSysTools, cleanTempFiles, normalisePath ) +import Packages ( dumpPackages, initPackages, haskell98PackageId ) import DriverPipeline ( staticLink, doMkDLL, runPipeline ) import DriverState ( buildStgToDo, findBuildTag, unregFlags, v_GhcMode, v_GhcModeFlag, GhcMode(..), v_Keep_tmp_files, v_Ld_inputs, v_Ways, v_Output_file, v_Output_hi, - readPackageConf, verifyOutputFiles, v_NoLink, - v_Build_tag + verifyOutputFiles, v_NoLink ) -import DriverFlags ( buildStaticHscOpts, - dynamic_flags, processArgs, static_flags) +import DriverFlags import DriverMkDepend ( beginMkDependHS, endMkDependHS ) import DriverPhases ( isSourceFilename ) import DriverUtil ( add, handle, handleDyn, later, unknownFlagsErr ) -import CmdLineOpts ( dynFlag, restoreDynFlags, - saveDynFlags, setDynFlags, getDynFlags, dynFlag, - DynFlags(..), HscLang(..), v_Static_hsc_opts - ) +import CmdLineOpts ( DynFlags(..), HscLang(..), v_Static_hsc_opts, + defaultDynFlags ) import BasicTypes ( failed ) import Outputable import Util @@ -113,28 +106,14 @@ main = exitWith (ExitFailure 1) ) $ do - -- make sure we clean up after ourselves - later (do forget_it <- readIORef v_Keep_tmp_files - unless forget_it $ do - verb <- dynFlag verbosity - cleanTempFiles verb - ) $ do - -- exceptions will be blocked while we clean the temporary files, - -- so there shouldn't be any difficulty if we receive further - -- signals. - installSignalHandlers argv <- getArgs let (minusB_args, argv') = partition (prefixMatch "-B") argv top_dir <- initSysTools minusB_args - -- Read the package configuration - conf_file <- getPackageConfigPath - readPackageConf conf_file - -- Process all the other arguments, and get the source files - non_static <- processArgs static_flags argv' [] + non_static <- processStaticFlags argv' mode <- readIORef v_GhcMode -- -O and --interactive are not a good combination @@ -150,7 +129,7 @@ main = way_opts <- findBuildTag let unreg_opts | cGhcUnregisterised == "YES" = unregFlags | otherwise = [] - extra_non_static <- processArgs static_flags (unreg_opts ++ way_opts) [] + extra_non_static <- processStaticFlags (unreg_opts ++ way_opts) -- Give the static flags to hsc static_opts <- buildStaticHscOpts @@ -164,27 +143,38 @@ main = -- set the "global" HscLang. The HscLang can be further adjusted on a module -- by module basis, using only the -fvia-C and -fasm flags. If the global -- HscLang is not HscC or HscAsm, -fvia-C and -fasm have no effect. - dyn_flags <- getDynFlags + let dflags0 = defaultDynFlags let lang = case mode of DoInteractive -> HscInterpreted DoEval _ -> HscInterpreted - _other -> hscLang dyn_flags + _other -> hscLang dflags0 - setDynFlags (dyn_flags{ stgToDo = stg_todo, - hscLang = lang, - -- leave out hscOutName for now - hscOutName = panic "Main.main:hscOutName not set", - verbosity = case mode of + let dflags1 = dflags0{ stgToDo = stg_todo, + hscLang = lang, + -- leave out hscOutName for now + hscOutName = panic "Main.main:hscOutName not set", + verbosity = case mode of DoEval _ -> 0 _other -> 1 - }) + } -- The rest of the arguments are "dynamic" -- Leftover ones are presumably files - fileish_args <- processArgs dynamic_flags (extra_non_static ++ non_static) [] + (dflags2, fileish_args) <- processDynamicFlags + (extra_non_static ++ non_static) dflags1 + + -- make sure we clean up after ourselves + later (do forget_it <- readIORef v_Keep_tmp_files + unless forget_it $ do + cleanTempFiles dflags2 + ) $ do + -- exceptions will be blocked while we clean the temporary files, + -- so there shouldn't be any difficulty if we receive further + -- signals. - -- save the "initial DynFlags" away - saveDynFlags + -- Read the package config(s), and process the package-related + -- command-line flags + dflags <- initPackages dflags2 let {- @@ -219,31 +209,32 @@ main = mapM_ (add v_Ld_inputs) (reverse objs) ---------------- Display banners and configuration ----------- - showBanners mode conf_file static_opts + showBanners mode dflags static_opts ---------------- Final sanity checking ----------- checkOptions mode srcs objs - -- We always link in the base package in - -- one-shot linking. Any other packages - -- required must be given using -package - -- options on the command-line. - let def_hs_pkgs = [basePackage, haskell98Package] - ---------------- Do the business ----------- + + -- Always link in the haskell98 package for static linking. Other + -- packages have to be specified via the -package flag. + let link_pkgs + | Just h98_id <- haskell98PackageId (pkgState dflags) = [h98_id] + | otherwise = [] + case mode of - DoMake -> doMake srcs + DoMake -> doMake dflags srcs DoMkDependHS -> do { beginMkDependHS ; - compileFiles mode srcs; - endMkDependHS } - StopBefore p -> do { compileFiles mode srcs; return () } - DoMkDLL -> do { o_files <- compileFiles mode srcs; - doMkDLL o_files def_hs_pkgs } - DoLink -> do { o_files <- compileFiles mode srcs; + compileFiles mode dflags srcs; + endMkDependHS dflags } + StopBefore p -> do { compileFiles mode dflags srcs; return () } + DoMkDLL -> do { o_files <- compileFiles mode dflags srcs; + doMkDLL dflags o_files link_pkgs } + DoLink -> do { o_files <- compileFiles mode dflags srcs; omit_linking <- readIORef v_NoLink; when (not omit_linking) - (staticLink o_files def_hs_pkgs) } + (staticLink dflags o_files link_pkgs) } #ifndef GHCI DoInteractive -> noInteractiveError @@ -251,8 +242,8 @@ main = where noInteractiveError = throwDyn (CmdLineError "not built for interactive use") #else - DoInteractive -> interactiveUI srcs Nothing - DoEval expr -> interactiveUI srcs (Just expr) + DoInteractive -> interactiveUI dflags srcs Nothing + DoEval expr -> interactiveUI dflags srcs (Just expr) #endif -- ----------------------------------------------------------------------------- @@ -294,17 +285,16 @@ isInteractive _ = False -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. -compileFiles :: GhcMode +compileFiles :: GhcMode + -> DynFlags -> [String] -- Source files -> IO [String] -- Object files -compileFiles mode srcs = do +compileFiles mode dflags srcs = do stop_flag <- readIORef v_GhcModeFlag - mapM (compileFile mode stop_flag) srcs + mapM (compileFile mode dflags stop_flag) srcs -compileFile mode stop_flag src = do - restoreDynFlags - +compileFile mode dflags stop_flag src = do exists <- doesFileExist src when (not exists) $ throwDyn (CmdLineError ("file `" ++ src ++ "' does not exist")) @@ -316,16 +306,16 @@ compileFile mode stop_flag src = do | mode==DoLink || mode==DoMkDLL = Nothing | otherwise = o_file - runPipeline mode stop_flag True maybe_o_file src Nothing{-no ModLocation-} + runPipeline mode dflags stop_flag True maybe_o_file src + Nothing{-no ModLocation-} -- ---------------------------------------------------------------------------- -- Run --make mode -doMake :: [String] -> IO () -doMake [] = throwDyn (UsageError "no input files") -doMake srcs = do - dflags <- getDynFlags +doMake :: DynFlags -> [String] -> IO () +doMake dflags [] = throwDyn (UsageError "no input files") +doMake dflags srcs = do state <- cmInit Batch dflags graph <- cmDepAnal state srcs (_, ok_flag, _) <- cmLoadModules state graph @@ -335,9 +325,9 @@ doMake srcs = do -- --------------------------------------------------------------------------- -- Various banners and verbosity output. -showBanners :: GhcMode -> FilePath -> [String] -> IO () -showBanners mode conf_file static_opts = do - verb <- dynFlag verbosity +showBanners :: GhcMode -> DynFlags -> [String] -> IO () +showBanners mode dflags static_opts = do + let verb = verbosity dflags -- Show the GHCi banner # ifdef GHCI @@ -346,17 +336,14 @@ showBanners mode conf_file static_opts = do # endif -- Display details of the configuration in verbose mode - when (verb >= 2) - (do hPutStr stderr "Glasgow Haskell Compiler, Version " - hPutStr stderr cProjectVersion - hPutStr stderr ", for Haskell 98, compiled by GHC version " - hPutStrLn stderr cBooterVersion) - - when (verb >= 2) - (hPutStrLn stderr ("Using package config file: " ++ conf_file)) + when (verb >= 2) $ + do hPutStr stderr "Glasgow Haskell Compiler, Version " + hPutStr stderr cProjectVersion + hPutStr stderr ", for Haskell 98, compiled by GHC version " + hPutStrLn stderr cBooterVersion - pkg_details <- getPackageConfigMap - showPackages pkg_details + when (verb >= 3) $ + dumpPackages dflags - when (verb >= 3) - (hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts)) + when (verb >= 3) $ + hPutStrLn stderr ("Hsc static flags: " ++ unwords static_opts) diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs index bd26ba10e9..f521cd38ee 100644 --- a/ghc/compiler/main/Packages.lhs +++ b/ghc/compiler/main/Packages.lhs @@ -5,118 +5,542 @@ \begin{code} module Packages ( - PackageConfig, - InstalledPackageInfo(..), showPackageId, - Version(..), - PackageIdentifier(..), - defaultPackageConfig, - packageDependents, - showPackages, - - PackageName, -- Instance of Outputable - mkPackageName, packageIdName, packageConfigName, packageNameString, - basePackage, rtsPackage, haskell98Package, thPackage, -- :: PackageName - - PackageConfigMap, emptyPkgMap, lookupPkg, - extendPackageConfigMap, getPackageDetails, getPackageConfigMap, + module PackageConfig, + + -- * The PackageConfigMap + PackageConfigMap, emptyPackageConfigMap, lookupPackage, + extendPackageConfigMap, dumpPackages, + + -- * Reading the package config, and processing cmdline args + PackageState(..), + initPackages, + moduleToPackageConfig, + getPackageDetails, + isHomeModule, + + -- * Inspecting the set of packages in scope + getPackageIncludePath, + getPackageCIncludes, + getPackageLibraryPath, + getPackageLinkOpts, + getPackageExtraCcOpts, + getPackageFrameworkPath, + getPackageFrameworks, + getExplicitPackagesAnd, + + -- * Utils + isDllName ) where #include "HsVersions.h" +import PackageConfig +import DriverState ( v_Build_tag, v_RTS_Build_tag, v_Static ) +import SysTools ( getTopDir, getPackageConfigPath ) +import ParsePkgConf ( loadPackageConfig ) +import CmdLineOpts ( DynFlags(..), PackageFlag(..), verbosity, + opt_Static ) +import Config ( cTARGETARCH, cTARGETOS, cProjectVersion ) +import Name ( Name, nameModule ) +import Module ( Module, mkModule ) +import UniqFM +import UniqSet +import Util +import Panic +import Outputable + +#if __GLASGOW_HASKELL__ >= 603 +import System.Directory ( getAppUserDataDirectory ) +#else +import Compat.Directory ( getAppUserDataDirectory ) +#endif + import Distribution.InstalledPackageInfo import Distribution.Package +import System.IO ( hPutStrLn, stderr ) import Data.Version -import CmdLineOpts ( dynFlag, verbosity ) -import ErrUtils ( dumpIfSet ) -import Outputable ( docToSDoc ) +import Data.Maybe ( fromJust, isNothing ) +import System.Directory ( doesFileExist ) +import Control.Monad ( when, foldM ) +import Data.List ( nub, partition ) import FastString -import UniqFM -import Util -import Pretty - import DATA_IOREF +import EXCEPTION ( throwDyn ) + +-- --------------------------------------------------------------------------- +-- The Package state + +-- Package state is all stored in DynFlags, including the details of +-- all packages, which packages are exposed, and which modules they +-- provide. + +-- The package state is computed by initPackages, and kept in DynFlags. +-- +-- * -package <pkg> causes <pkg> to become exposed, and all other packages +-- with the same name to become hidden. +-- +-- * -hide-package <pkg> causes <pkg> to become hidden. +-- +-- * Let exposedPackages be the set of packages thus exposed. +-- 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. +-- +-- * When searching for a module from an implicit import, all modules +-- from depExposedPackages are valid. +-- +-- * When linking in a comp manager mode, we link in packages the +-- program depends on (the compiler knows this list by the +-- time it gets to the link step). Also, we link in all packages +-- which were mentioned with explicit -package flags on the command-line, +-- or are a transitive dependency of same, or are "base"/"rts". +-- The reason for (b) is that we might need packages which don't +-- 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 +-- know whether B will be in the same DLL as A. +-- If it's in the same DLL, we refer to B_f_closure +-- If it isn't, we refer to _imp__B_f_closure +-- When compiling A, we record in B's Module value whether it's +-- in a different DLL, by setting the DLL flag. + +data PackageState = PackageState { + + explicitPackages :: [PackageId], + -- The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. + + pkgIdMap :: PackageConfigMap, -- PackageId -> PackageConfig + -- mapping derived from the package databases and + -- command-line package flags. + + moduleToPkgConf :: UniqFM (PackageConfig,Bool), + -- 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 :: Maybe PackageId, + rtsPackageId :: Maybe PackageId, + haskell98PackageId :: Maybe PackageId, + thPackageId :: Maybe PackageId + } + +-- A PackageConfigMap maps a PackageId to a PackageConfig +type PackageConfigMap = UniqFM PackageConfig + +emptyPackageConfigMap :: PackageConfigMap +emptyPackageConfigMap = emptyUFM + +lookupPackage :: PackageConfigMap -> PackageId -> Maybe PackageConfig +lookupPackage = lookupUFM + +extendPackageConfigMap + :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap +extendPackageConfigMap pkg_map new_pkgs + = foldl add pkg_map new_pkgs + where add pkg_map p = addToUFM pkg_map (packageConfigId p) p + +getPackageDetails :: PackageState -> PackageId -> PackageConfig +getPackageDetails dflags ps = fromJust (lookupPackage (pkgIdMap dflags) ps) + +-- ---------------------------------------------------------------------------- +-- Loading the package config files and building up the package state + +initPackages :: DynFlags -> IO DynFlags +initPackages dflags = do + pkg_map <- readPackageConfigs dflags; + state <- mkPackageState dflags pkg_map + return dflags{ pkgState = state } -- ----------------------------------------------------------------------------- --- Our PackageConfig type is just InstalledPackageInfo from Cabal. Later we --- might need to extend it with some GHC-specific stuff, but for now it's fine. +-- Reading the package database(s) + +readPackageConfigs :: DynFlags -> IO PackageConfigMap +readPackageConfigs dflags = do + -- System one always comes first + system_pkgconf <- getPackageConfigPath + pkg_map1 <- readPackageConfig dflags emptyPackageConfigMap system_pkgconf + + -- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf) + -- unless the -no-user-package-conf flag was given. + -- We only do this when getAppUserDataDirectory is available + -- (GHC >= 6.3). + appdir <- getAppUserDataDirectory "ghc" + let + pkgconf = appdir ++ '/':cTARGETARCH ++ '-':cTARGETOS + ++ '-':cProjectVersion ++ "/package.conf" + -- + exists <- doesFileExist pkgconf + pkg_map2 <- if (readUserPkgConf dflags && exists) + then readPackageConfig dflags pkg_map1 pkgconf + else return pkg_map1 + + -- Read all the ones mentioned in -package-conf flags + pkg_map <- foldM (readPackageConfig dflags) pkg_map2 + (extraPkgConfs dflags) + + return pkg_map + + +readPackageConfig + :: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap +readPackageConfig dflags pkg_map conf_file = do + when (verbosity dflags >= 2) $ + hPutStrLn stderr ("Reading package config file: " + ++ conf_file) + proto_pkg_configs <- loadPackageConfig conf_file + top_dir <- getTopDir + let pkg_configs = mungePackagePaths top_dir proto_pkg_configs + return (extendPackageConfigMap pkg_map pkg_configs) + + +mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig] +-- Replace the string "$libdir" at the beginning of a path +-- with the current libdir (obtained from the -B option). +mungePackagePaths top_dir ps = map munge_pkg ps + where + munge_pkg p = p{ importDirs = munge_paths (importDirs p), + includeDirs = munge_paths (includeDirs p), + libraryDirs = munge_paths (libraryDirs p), + frameworkDirs = munge_paths (frameworkDirs p) } + + munge_paths = map munge_path + + munge_path p + | Just p' <- maybePrefixMatch "$libdir" p = top_dir ++ p' + | otherwise = p -type PackageConfig = InstalledPackageInfo -defaultPackageConfig = emptyInstalledPackageInfo -- ----------------------------------------------------------------------------- --- Package names +-- 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 dflags pkg_db = do + -- + -- Modify the package database according to the command-line flags + -- (-package, -hide-package, -ignore-package). + -- + -- Also, here we build up a set of the packages mentioned in -package + -- flags on the command line; these are called the "explicit" packages. + -- we link these packages in eagerly. The explicit set should contain + -- at least rts & base, which is why we pretend that the command line + -- contains -package rts & -package base. + -- + let + flags = reverse (packageFlags dflags) + + procflags pkgs expl [] = return (pkgs,expl) + procflags pkgs expl (ExposePackage str : flags) = do + case partition (matches str) pkgs of + ([],_) -> missingPackageErr str + ([p],ps) -> procflags (p':ps) (addOneToUniqSet expl pkgid) flags + where pkgid = packageConfigId p + p' = p {exposed=True} + (ps,_) -> multiplePackagesErr str ps + procflags pkgs expl (HidePackage str : flags) = do + case partition (matches str) pkgs of + ([],_) -> missingPackageErr str + ([p],ps) -> procflags (p':ps) expl flags + where p' = p {exposed=False} + (ps,_) -> multiplePackagesErr str ps + procflags pkgs expl (IgnorePackage str : flags) = do + case partition (matches str) pkgs of + ([],_) -> missingPackageErr str + (ps,qs) -> procflags qs expl flags -type PackageName = FastString -- No encoding at all + -- A package named on the command line can either include the + -- version, or just the name if it is unambiguous. + matches str p + = str == showPackageId (package p) + || str == pkgName (package p) + -- + (pkgs1,explicit) <- procflags (eltsUFM pkg_db) emptyUniqSet flags + -- + let + elimDanglingDeps pkgs = + case partition (hasDanglingDeps pkgs) pkgs of + ([],ps) -> ps + (ps,qs) -> elimDanglingDeps qs -mkPackageName :: String -> PackageName -mkPackageName = mkFastString + hasDanglingDeps pkgs p = any dangling (depends p) + where dangling pid = pid `notElem` all_pids + all_pids = map package pkgs + -- + -- Eliminate any packages which have dangling dependencies (perhaps + -- because the package was removed by -ignore-package). + -- + let pkgs = elimDanglingDeps pkgs1 + 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 nm = + case [ conf | p <- dep_exposed, + Just conf <- [lookupPackage pkg_db p], + nm == mkFastString (pkgName (package conf)) ] of + [] -> Nothing + (p:ps) -> Just (mkPackageId (package p)) -packageIdName :: PackageIdentifier -> PackageName -packageIdName = mkPackageName . showPackageId + -- 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 -packageConfigName :: PackageConfig -> PackageName -packageConfigName = packageIdName . package + -- add base & rts to the explicit packages + basicLinkedPackages = [basePackageId,rtsPackageId] + explicit' = addListToUniqSet explicit + [ p | Just p <- basicLinkedPackages ] + -- + -- Close the explicit packages with their dependencies + -- + dep_explicit <- closeDeps pkg_db (uniqSetToList explicit') + -- + -- Build up a mapping from Module -> PackageConfig for all modules. + -- Discover any conflicts at the same time, and factor in the new exposed + -- status of each package. + -- + let + extend_modmap modmap pkgname = do + let + pkg = fromJust (lookupPackage pkg_db pkgname) + exposed_mods = map mkModule (exposedModules pkg) + hidden_mods = map mkModule (hiddenModules pkg) + all_mods = exposed_mods ++ hidden_mods + -- + -- check for overlaps + -- + let + overlaps = [ (m,pkg) | m <- all_mods, + Just (pkg,_) <- [lookupUFM modmap m] ] + -- + when (not (null overlaps)) $ overlappingError pkg overlaps + -- + let + return (addListToUFM modmap + [(m, (pkg, m `elem` exposed_mods)) + | m <- all_mods]) + -- + mod_map <- foldM extend_modmap emptyUFM dep_exposed -packageNameString :: PackageName -> String -packageNameString = unpackFS + return PackageState{ explicitPackages = dep_explicit, + pkgIdMap = pkg_db, + moduleToPkgConf = mod_map, + basePackageId = basePackageId, + rtsPackageId = rtsPackageId, + haskell98PackageId = haskell98PackageId, + thPackageId = thPackageId + } + -- done! -rtsPackage, basePackage, haskell98Package, thPackage :: PackageName -basePackage = FSLIT("base") -rtsPackage = FSLIT("rts") -haskell98Package = FSLIT("haskell98") -thPackage = FSLIT("template-haskell") -- Template Haskell libraries in here +basePackageName = FSLIT("base") +rtsPackageName = FSLIT("rts") +haskell98PackageName = FSLIT("haskell98") +thPackageName = FSLIT("template-haskell") + -- Template Haskell libraries in here -packageDependents :: PackageConfig -> [PackageName] --- Impedence matcher, because PackageConfig has Strings --- not PackageNames at the moment. Sigh. -packageDependents pkg = map packageIdName (depends pkg) +overlappingError pkg overlaps + = throwDyn (CmdLineError (showSDoc (vcat (map msg overlaps)))) + where + this_pkg = text (showPackageId (package pkg)) + msg (mod,other_pkg) = + text "Error: module '" <> ppr mod + <> text "' is exposed by package " + <> this_pkg <> text " and package " + <> text (showPackageId (package other_pkg)) + +multiplePackagesErr str ps = + throwDyn (CmdLineError (showSDoc ( + text "Error; multiple packages match" <+> + text str <> colon <> + sep (punctuate comma (map (text.showPackageId.package) ps)) + ))) -- ----------------------------------------------------------------------------- --- A PackageConfigMap maps a PackageName to a PackageConfig +-- Extracting information from the packages in scope -type PackageConfigMap = UniqFM PackageConfig +-- Many of these functions take a list of packages: in those cases, +-- the list is expected to contain the "dependent packages", +-- i.e. those packages that were found to be depended on by the +-- current module/program. These can be auto or non-auto packages, it +-- doesn't really matter. The list is always combined with the list +-- of explicit (command-line) packages to determine which packages to +-- use. -lookupPkg :: PackageConfigMap -> PackageName -> Maybe PackageConfig +getPackageIncludePath :: DynFlags -> [PackageId] -> IO [String] +getPackageIncludePath dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (nub (filter notNull (concatMap includeDirs ps))) -emptyPkgMap :: PackageConfigMap + -- includes are in reverse dependency order (i.e. rts first) +getPackageCIncludes :: [PackageConfig] -> IO [String] +getPackageCIncludes pkg_configs = do + return (reverse (nub (filter notNull (concatMap includes pkg_configs)))) -emptyPkgMap = emptyUFM -lookupPkg = lookupUFM +getPackageLibraryPath :: DynFlags -> [PackageId] -> IO [String] +getPackageLibraryPath dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (nub (filter notNull (concatMap libraryDirs ps))) -extendPkgMap :: PackageConfigMap -> [PackageConfig] -> PackageConfigMap -extendPkgMap pkg_map new_pkgs - = foldl add pkg_map new_pkgs +getPackageLinkOpts :: DynFlags -> [PackageId] -> IO [String] +getPackageLinkOpts dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + tag <- readIORef v_Build_tag + rts_tag <- readIORef v_RTS_Build_tag + static <- readIORef v_Static + let + imp = if static then "" else "_imp" + libs p = map addSuffix (hACK (hsLibraries p)) ++ extraLibraries p + imp_libs p = map (++imp) (libs p) + all_opts p = map ("-l" ++) (imp_libs p) ++ extraLdOpts p + + suffix = if null tag then "" else '_':tag + rts_suffix = if null rts_tag then "" else '_':rts_tag + + addSuffix rts@"HSrts" = rts ++ rts_suffix + addSuffix other_lib = other_lib ++ suffix + + return (concat (map all_opts ps)) where - add pkg_map p = addToUFM pkg_map (packageConfigName p) p -GLOBAL_VAR(v_Package_details, emptyPkgMap, PackageConfigMap) + -- This is a totally horrible (temporary) hack, for Win32. Problem is + -- that package.conf for Win32 says that the main prelude lib is + -- split into HSbase1, HSbase2 and HSbase3, which is needed due to a bug + -- in the GNU linker (PEi386 backend). However, we still only + -- have HSbase.a for static linking, not HSbase{1,2,3}.a + -- getPackageLibraries is called to find the .a's to add to the static + -- link line. On Win32, this hACK detects HSbase{1,2,3} and + -- replaces them with HSbase, so static linking still works. + -- Libraries needed for dynamic (GHCi) linking are discovered via + -- different route (in InteractiveUI.linkPackage). + -- See driver/PackageSrc.hs for the HSbase1/HSbase2 split definition. + -- THIS IS A STRICTLY TEMPORARY HACK (famous last words ...) + -- JRS 04 Sept 01: Same appalling hack for HSwin32[1,2] + -- KAA 29 Mar 02: Same appalling hack for HSobjectio[1,2,3,4] + hACK libs +# if !defined(mingw32_TARGET_OS) && !defined(cygwin32_TARGET_OS) + = libs +# else + = if "HSbase1" `elem` libs && "HSbase2" `elem` libs && "HSbase3" `elem` libs + then "HSbase" : filter (not.(isPrefixOf "HSbase")) libs + else + if "HSwin321" `elem` libs && "HSwin322" `elem` libs + then "HSwin32" : filter (not.(isPrefixOf "HSwin32")) libs + else + if "HSobjectio1" `elem` libs && "HSobjectio2" `elem` libs && "HSobjectio3" `elem` libs && "HSobjectio4" `elem` libs + then "HSobjectio" : filter (not.(isPrefixOf "HSobjectio")) libs + else + libs +# endif + +getPackageExtraCcOpts :: DynFlags -> [PackageId] -> IO [String] +getPackageExtraCcOpts dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (concatMap extraCcOpts ps) + +getPackageFrameworkPath :: DynFlags -> [PackageId] -> IO [String] +getPackageFrameworkPath dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (nub (filter notNull (concatMap frameworkDirs ps))) + +getPackageFrameworks :: DynFlags -> [PackageId] -> IO [String] +getPackageFrameworks dflags pkgs = do + ps <- getExplicitPackagesAnd dflags pkgs + return (concatMap extraFrameworks ps) + +-- ----------------------------------------------------------------------------- +-- Package Utils -getPackageConfigMap :: IO PackageConfigMap -getPackageConfigMap = readIORef v_Package_details +-- 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. +moduleToPackageConfig :: DynFlags -> Module -> Maybe (PackageConfig,Bool) +moduleToPackageConfig dflags m = + lookupUFM (moduleToPkgConf (pkgState dflags)) m -extendPackageConfigMap :: [PackageConfig] -> IO () -extendPackageConfigMap pkg_configs = do - old_pkg_map <- readIORef v_Package_details - writeIORef v_Package_details (extendPkgMap old_pkg_map pkg_configs) +isHomeModule :: DynFlags -> Module -> Bool +isHomeModule dflags mod = isNothing (moduleToPackageConfig dflags mod) -getPackageDetails :: [PackageName] -> IO [PackageConfig] -getPackageDetails ps = do - pkg_details <- getPackageConfigMap - return [ pkg | Just pkg <- map (lookupPkg pkg_details) ps ] +getExplicitPackagesAnd :: DynFlags -> [PackageId] -> IO [PackageConfig] +getExplicitPackagesAnd dflags pkgids = + let + state = pkgState dflags + pkg_map = pkgIdMap state + expl = explicitPackages state + in do + all_pkgs <- foldM (add_package pkg_map) expl pkgids + return (map (getPackageDetails state) all_pkgs) +-- Takes a list of packages, and returns the list with dependencies included, +-- in reverse dependency order (a package appears before those it depends on). +closeDeps :: PackageConfigMap -> [PackageId] -> IO [PackageId] +closeDeps pkg_map ps = foldM (add_package pkg_map) [] ps + +-- internal helper +add_package :: PackageConfigMap -> [PackageId] -> PackageId -> IO [PackageId] +add_package pkg_db ps p + | p `elem` ps = return ps -- Check if we've already added this package + | otherwise = + case lookupPackage pkg_db p of + Nothing -> missingPackageErr (packageIdString p) + Just pkg -> do + -- Add the package's dependents also + let deps = map mkPackageId (depends pkg) + ps' <- foldM (add_package pkg_db) ps deps + return (p : ps') + +missingPackageErr p = throwDyn (CmdLineError ("unknown package: " ++ p)) + +-- ----------------------------------------------------------------------------- +-- 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 :: DynFlags -> Name -> Bool +isDllName dflags name + | opt_Static = False + | otherwise = + case lookupUFM (moduleToPkgConf (pkgState dflags)) (nameModule name) of + Just _ -> True -- yes, its a package module + Nothing -> False -- no, must be a home module -- ----------------------------------------------------------------------------- -- Displaying packages -showPackages :: PackageConfigMap -> IO () +dumpPackages :: DynFlags -> IO () -- Show package info on console, if verbosity is >= 3 -showPackages pkg_map - = do { verb <- dynFlag verbosity - ; dumpIfSet (verb >= 3) "Packages" - (docToSDoc (vcat (map (text.showInstalledPackageInfo) ps))) - } - where - ps = eltsUFM pkg_map - +dumpPackages dflags + = do let pkg_map = pkgIdMap (pkgState dflags) + hPutStrLn stderr $ showSDoc $ + vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map)) \end{code} diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index 1a4795e8a7..a3c78cfbd8 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -3,7 +3,7 @@ module ParsePkgConf( loadPackageConfig ) where #include "HsVersions.h" -import Packages +import PackageConfig import Lexer import CmdLineOpts import FastString diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs index 06850ef4d3..e37683f59a 100644 --- a/ghc/compiler/main/SysTools.lhs +++ b/ghc/compiler/main/SysTools.lhs @@ -70,7 +70,7 @@ import Config import Outputable import Panic ( GhcException(..) ) import Util ( global, notNull ) -import CmdLineOpts ( dynFlag, verbosity ) +import CmdLineOpts ( DynFlags(..) ) import EXCEPTION ( throwDyn ) import DATA_IOREF ( IORef, readIORef, writeIORef ) @@ -534,60 +534,71 @@ showOpt (Option s) = s \begin{code} -runUnlit :: [Option] -> IO () -runUnlit args = do p <- readIORef v_Pgm_L - runSomething "Literate pre-processor" p args - -runCpp :: [Option] -> IO () -runCpp args = do (p,baseArgs) <- readIORef v_Pgm_P - runSomething "C pre-processor" p (baseArgs ++ args) - -runPp :: [Option] -> IO () -runPp args = do p <- readIORef v_Pgm_F - runSomething "Haskell pre-processor" p args - -runCc :: [Option] -> IO () -runCc args = do (p,args0) <- readIORef v_Pgm_c - runSomething "C Compiler" p (args0++args) - -runMangle :: [Option] -> IO () -runMangle args = do (p,args0) <- readIORef v_Pgm_m - runSomething "Mangler" p (args0++args) - -runSplit :: [Option] -> IO () -runSplit args = do (p,args0) <- readIORef v_Pgm_s - runSomething "Splitter" p (args0++args) - -runAs :: [Option] -> IO () -runAs args = do (p,args0) <- readIORef v_Pgm_a - runSomething "Assembler" p (args0++args) - -runLink :: [Option] -> IO () -runLink args = do (p,args0) <- readIORef v_Pgm_l - runSomething "Linker" p (args0++args) +runUnlit :: DynFlags -> [Option] -> IO () +runUnlit dflags args = do + p <- readIORef v_Pgm_L + runSomething dflags "Literate pre-processor" p args + +runCpp :: DynFlags -> [Option] -> IO () +runCpp dflags args = do + (p,baseArgs) <- readIORef v_Pgm_P + runSomething dflags "C pre-processor" p (baseArgs ++ args) + +runPp :: DynFlags -> [Option] -> IO () +runPp dflags args = do + p <- readIORef v_Pgm_F + runSomething dflags "Haskell pre-processor" p args + +runCc :: DynFlags -> [Option] -> IO () +runCc dflags args = do + (p,args0) <- readIORef v_Pgm_c + runSomething dflags "C Compiler" p (args0++args) + +runMangle :: DynFlags -> [Option] -> IO () +runMangle dflags args = do + (p,args0) <- readIORef v_Pgm_m + runSomething dflags "Mangler" p (args0++args) + +runSplit :: DynFlags -> [Option] -> IO () +runSplit dflags args = do + (p,args0) <- readIORef v_Pgm_s + runSomething dflags "Splitter" p (args0++args) + +runAs :: DynFlags -> [Option] -> IO () +runAs dflags args = do + (p,args0) <- readIORef v_Pgm_a + runSomething dflags "Assembler" p (args0++args) + +runLink :: DynFlags -> [Option] -> IO () +runLink dflags args = do + (p,args0) <- readIORef v_Pgm_l + runSomething dflags "Linker" p (args0++args) #ifdef ILX -runIlx2il :: [Option] -> IO () -runIlx2il args = do p <- readIORef v_Pgm_I - runSomething "Ilx2Il" p args - -runIlasm :: [Option] -> IO () -runIlasm args = do p <- readIORef v_Pgm_i - runSomething "Ilasm" p args +runIlx2il :: DynFlags -> [Option] -> IO () +runIlx2il dflags args = do + p <- readIORef v_Pgm_I + runSomething dflags "Ilx2Il" p args + +runIlasm :: DynFlags -> [Option] -> IO () +runIlasm dflags args = do + p <- readIORef v_Pgm_i + runSomething dflags "Ilasm" p args #endif -runMkDLL :: [Option] -> IO () -runMkDLL args = do (p,args0) <- readIORef v_Pgm_MkDLL - runSomething "Make DLL" p (args0++args) +runMkDLL :: DynFlags -> [Option] -> IO () +runMkDLL dflags args = do + (p,args0) <- readIORef v_Pgm_MkDLL + runSomething dflags "Make DLL" p (args0++args) -touch :: String -> String -> IO () -touch purpose arg = do p <- readIORef v_Pgm_T - runSomething purpose p [FileOption "" arg] +touch :: DynFlags -> String -> String -> IO () +touch dflags purpose arg = do + p <- readIORef v_Pgm_T + runSomething dflags purpose p [FileOption "" arg] -copy :: String -> String -> String -> IO () -copy purpose from to = do - verb <- dynFlag verbosity - when (verb >= 2) $ hPutStrLn stderr ("*** " ++ purpose) +copy :: DynFlags -> String -> String -> String -> IO () +copy dflags purpose from to = do + when (verbosity dflags >= 2) $ hPutStrLn stderr ("*** " ++ purpose) h <- openFile to WriteMode ls <- readFile from -- inefficient, but it'll do for now. @@ -653,17 +664,17 @@ setTmpDir dir = writeIORef v_TmpDir (canonicalise dir) _ -> path #endif -cleanTempFiles :: Int -> IO () -cleanTempFiles verb +cleanTempFiles :: DynFlags -> IO () +cleanTempFiles dflags = do fs <- readIORef v_FilesToClean - removeTmpFiles verb fs + removeTmpFiles dflags fs writeIORef v_FilesToClean [] -cleanTempFilesExcept :: Int -> [FilePath] -> IO () -cleanTempFilesExcept verb dont_delete +cleanTempFilesExcept :: DynFlags -> [FilePath] -> IO () +cleanTempFilesExcept dflags dont_delete = do files <- readIORef v_FilesToClean let (to_keep, to_delete) = partition (`elem` dont_delete) files - removeTmpFiles verb to_delete + removeTmpFiles dflags to_delete writeIORef v_FilesToClean to_keep @@ -685,13 +696,15 @@ addFilesToClean :: [FilePath] -> IO () -- May include wildcards [used by DriverPipeline.run_phase SplitMangle] addFilesToClean files = mapM_ (add v_FilesToClean) files -removeTmpFiles :: Int -> [FilePath] -> IO () -removeTmpFiles verb fs +removeTmpFiles :: DynFlags -> [FilePath] -> IO () +removeTmpFiles dflags fs = warnNon $ - traceCmd "Deleting temp files" + traceCmd dflags "Deleting temp files" ("Deleting: " ++ unwords deletees) (mapM_ rm deletees) where + verb = verbosity dflags + -- Flat out refuse to delete files that are likely to be source input -- files (is there a worse bug than having a compiler delete your source -- files?) @@ -730,16 +743,17 @@ setDryRun = writeIORef v_Dry_run True ----------------------------------------------------------------------------- -- Running an external program -runSomething :: String -- For -v message +runSomething :: DynFlags + -> String -- For -v message -> String -- Command name (possibly a full path) -- assumed already dos-ified -> [Option] -- Arguments -- runSomething will dos-ify them -> IO () -runSomething phase_name pgm args = do +runSomething dflags phase_name pgm args = do let real_args = filter notNull (map showOpt args) - traceCmd phase_name (unwords (pgm:real_args)) $ do + traceCmd dflags phase_name (unwords (pgm:real_args)) $ do exit_code <- rawSystem pgm real_args case exit_code of ExitSuccess -> @@ -754,11 +768,11 @@ runSomething phase_name pgm args = do ExitFailure _other -> throwDyn (PhaseFailed phase_name exit_code) -traceCmd :: String -> String -> IO () -> IO () +traceCmd :: DynFlags -> String -> String -> IO () -> IO () -- a) trace the command (at two levels of verbosity) -- b) don't do it at all if dry-run is set -traceCmd phase_name cmd_line action - = do { verb <- dynFlag verbosity +traceCmd dflags phase_name cmd_line action + = do { let verb = verbosity dflags ; when (verb >= 2) $ hPutStrLn stderr ("*** " ++ phase_name) ; when (verb >= 3) $ hPutStrLn stderr cmd_line ; hFlush stderr diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index c925735c04..bcafd651bc 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -8,7 +8,7 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), dopt ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) @@ -157,7 +157,7 @@ tidyCorePgm hsc_env -- The type environment is a convenient source of such things. ; (final_env, tidy_binds) - <- tidyTopBinds mod nc_var ext_ids init_env binds_in + <- tidyTopBinds dflags mod nc_var ext_ids init_env binds_in ; let tidy_rules = tidyIdRules final_env ext_rules @@ -401,38 +401,40 @@ addExternal omit_iface_prags (id,rhs) needed -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -tidyTopBinds :: Module +tidyTopBinds :: DynFlags + -> Module -> IORef NameCache -- For allocating new unique names -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too -> TidyEnv -> [CoreBind] -> IO (TidyEnv, [CoreBind]) -tidyTopBinds mod nc_var ext_ids tidy_env [] +tidyTopBinds dflags mod nc_var ext_ids tidy_env [] = return (tidy_env, []) -tidyTopBinds mod nc_var ext_ids tidy_env (b:bs) - = do { (tidy_env1, b') <- tidyTopBind mod nc_var ext_ids tidy_env b - ; (tidy_env2, bs') <- tidyTopBinds mod nc_var ext_ids tidy_env1 bs +tidyTopBinds dflags mod nc_var ext_ids tidy_env (b:bs) + = do { (tidy_env1, b') <- tidyTopBind dflags mod nc_var ext_ids tidy_env b + ; (tidy_env2, bs') <- tidyTopBinds dflags mod nc_var ext_ids tidy_env1 bs ; return (tidy_env2, b':bs') } ------------------------ -tidyTopBind :: Module +tidyTopBind :: DynFlags + -> Module -> IORef NameCache -- For allocating new unique names -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too -> TidyEnv -> CoreBind -> IO (TidyEnv, CoreBind) -tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) +tidyTopBind dflags 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 subst1 (idArity bndr) rhs + caf_info = hasCafRefs dflags subst1 (idArity bndr) rhs -tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) +tidyTopBind dflags 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 @@ -445,7 +447,7 @@ tidyTopBind mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info - | or [ mayHaveCafRefs (hasCafRefs subst1 (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs dflags subst1 (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -620,13 +622,13 @@ it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: VarEnv Var -> Arity -> CoreExpr -> CafInfo -hasCafRefs p arity expr +hasCafRefs :: DynFlags -> VarEnv Var -> Arity -> CoreExpr -> CafInfo +hasCafRefs dflags p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefs p expr) - is_caf = not (arity > 0 || rhsIsStatic expr) + is_caf = not (arity > 0 || rhsIsStatic dflags expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity -- knows how much eta expansion is going to be done by diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp index 4187789d08..e8144a692a 100644 --- a/ghc/compiler/parser/Parser.y.pp +++ b/ghc/compiler/parser/Parser.y.pp @@ -283,9 +283,7 @@ TH_TY_QUOTE { L _ ITtyQuote } -- ''T module :: { Located (HsModule RdrName) } : 'module' modid maybemoddeprec maybeexports 'where' body {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule (Just (L (getLoc $2) - (mkHomeModule (unLoc $2)))) - $4 (fst $6) (snd $6) $3)) } + return (L loc (HsModule (Just $2) $4 (fst $6) (snd $6) $3)) } | missing_module_keyword top close {% fileSrcSpan >>= \ loc -> return (L loc (HsModule Nothing Nothing @@ -397,7 +395,7 @@ optqualified :: { Bool } : 'qualified' { True } | {- empty -} { False } -maybeas :: { Located (Maybe ModuleName) } +maybeas :: { Located (Maybe Module) } : 'as' modid { LL (Just (unLoc $2)) } | {- empty -} { noLoc Nothing } @@ -1511,10 +1509,10 @@ close :: { () } ----------------------------------------------------------------------------- -- Miscellaneous (mostly renamings) -modid :: { Located ModuleName } - : CONID { L1 $ mkModuleNameFS (getCONID $1) } +modid :: { Located Module } + : CONID { L1 $ mkModuleFS (getCONID $1) } | QCONID { L1 $ let (mod,c) = getQCONID $1 in - mkModuleNameFS + mkModuleFS (mkFastString (unpackFS mod ++ '.':unpackFS c)) } diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index 75f7b1b365..33f4aad3ac 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -8,7 +8,7 @@ import HsSyn import RdrName import OccName import Kind( Kind(..) ) -import Name( nameOccName, nameModuleName ) +import Name( nameOccName, nameModule ) import Module import ParserCoreUtils import LexCore @@ -69,11 +69,10 @@ import Char %% module :: { HsExtCore RdrName } - : '%module' modid tdefs vdefgs - { HsExtCore (mkHomeModule $2) $3 $4 } + : '%module' modid tdefs vdefgs { HsExtCore $2 $3 $4 } -modid :: { ModuleName } - : CNAME { mkSysModuleNameFS (mkFastString $1) } +modid :: { Module } + : CNAME { mkSysModuleFS (mkFastString $1) } ------------------------------------------------------------- -- Type and newtype declarations are in HsSyn syntax @@ -299,7 +298,7 @@ convRatLit i aty eqTc :: IfaceTyCon -> TyCon -> Bool -- Ugh! eqTc (IfaceTc (ExtPkg mod occ)) tycon - = mod == nameModuleName nm && occ == nameOccName nm + = mod == nameModule nm && occ == nameOccName nm where nm = tyConName tycon diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index cfbbaa7b64..236d53859a 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -50,7 +50,8 @@ module RdrHsSyn ( import HsSyn -- Lots of it import IfaceType -import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) +import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache, + IfacePackage(..) ) import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..), IfaceConDecl(..), IfaceConDecls(..) ) import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, @@ -65,9 +66,8 @@ import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, occNameUserString, isValOcc ) import BasicTypes ( initialVersion, StrictnessMark(..) ) -import Module ( ModuleName ) +import Module ( Module ) import SrcLoc -import CmdLineOpts ( opt_InPackage ) import OrdList ( OrdList, fromOL ) import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable @@ -206,11 +206,12 @@ to get hi-boot files right! \begin{code} -mkBootIface :: ModuleName -> [HsDecl RdrName] -> ModIface +mkBootIface :: Module -> [HsDecl RdrName] -> ModIface -- Make the ModIface for a hi-boot file -- The decls are of very limited form +-- The package will be filled in later (see LoadIface.readIface) mkBootIface mod decls - = (emptyModIface opt_InPackage mod) { + = (emptyModIface ThisPackage{-fill in later-} mod) { mi_boot = True, mi_exports = [(mod, map mk_export decls')], mi_decls = decls_w_vers, diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index f534abe659..a180e61461 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -49,7 +49,7 @@ module PrelNames ( #include "HsVersions.h" -import Module ( Module, mkBasePkgModule, mkHomeModule, mkModuleName ) +import Module ( Module, mkModule ) import OccName ( dataName, tcName, clsName, varName, mkOccFS ) @@ -57,10 +57,10 @@ import RdrName ( RdrName, nameRdrName, mkOrig, rdrNameOcc, mkUnqual ) import Unique ( Unique, Uniquable(..), hasKey, mkPreludeMiscIdUnique, mkPreludeDataConUnique, mkPreludeTyConUnique, mkPreludeClassUnique, - mkTupleTyConUnique, isTupleKey + mkTupleTyConUnique ) import BasicTypes ( Boxity(..), Arity ) -import Name ( Name, mkInternalName, mkExternalName, nameUnique, nameModule ) +import Name ( Name, mkInternalName, mkExternalName, nameModule ) import SrcLoc ( noSrcLoc ) import FastString \end{code} @@ -218,89 +218,54 @@ genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] --MetaHaskell Extension Add a new module here \begin{code} -pRELUDE_Name = mkModuleName "Prelude" -gHC_PRIM_Name = mkModuleName "GHC.Prim" -- Primitive types and values -pREL_BASE_Name = mkModuleName "GHC.Base" -pREL_ENUM_Name = mkModuleName "GHC.Enum" -pREL_SHOW_Name = mkModuleName "GHC.Show" -pREL_READ_Name = mkModuleName "GHC.Read" -pREL_NUM_Name = mkModuleName "GHC.Num" -pREL_LIST_Name = mkModuleName "GHC.List" -pREL_PARR_Name = mkModuleName "GHC.PArr" -pREL_TUP_Name = mkModuleName "Data.Tuple" -pREL_EITHER_Name = mkModuleName "Data.Either" -pREL_PACK_Name = mkModuleName "GHC.Pack" -pREL_CONC_Name = mkModuleName "GHC.Conc" -pREL_IO_BASE_Name = mkModuleName "GHC.IOBase" -pREL_ST_Name = mkModuleName "GHC.ST" -pREL_ARR_Name = mkModuleName "GHC.Arr" -pREL_BYTEARR_Name = mkModuleName "PrelByteArr" -pREL_STABLE_Name = mkModuleName "GHC.Stable" -pREL_ADDR_Name = mkModuleName "GHC.Addr" -pREL_PTR_Name = mkModuleName "GHC.Ptr" -pREL_ERR_Name = mkModuleName "GHC.Err" -pREL_REAL_Name = mkModuleName "GHC.Real" -pREL_FLOAT_Name = mkModuleName "GHC.Float" -pREL_TOP_HANDLER_Name = mkModuleName "GHC.TopHandler" -sYSTEM_IO_Name = mkModuleName "System.IO" -dYNAMIC_Name = mkModuleName "Data.Dynamic" -tYPEABLE_Name = mkModuleName "Data.Typeable" -gENERICS_Name = mkModuleName "Data.Generics.Basics" -dOTNET_Name = mkModuleName "GHC.Dotnet" - -rEAD_PREC_Name = mkModuleName "Text.ParserCombinators.ReadPrec" -lEX_Name = mkModuleName "Text.Read.Lex" - -mAIN_Name = mkModuleName "Main" -pREL_INT_Name = mkModuleName "GHC.Int" -pREL_WORD_Name = mkModuleName "GHC.Word" -mONAD_FIX_Name = mkModuleName "Control.Monad.Fix" -aRROW_Name = mkModuleName "Control.Arrow" -aDDR_Name = mkModuleName "Addr" - -gLA_EXTS_Name = mkModuleName "GHC.Exts" - -gHC_PRIM = mkBasePkgModule gHC_PRIM_Name -pREL_BASE = mkBasePkgModule pREL_BASE_Name -pREL_TUP = mkBasePkgModule pREL_TUP_Name -pREL_EITHER = mkBasePkgModule pREL_EITHER_Name -pREL_LIST = mkBasePkgModule pREL_LIST_Name -pREL_SHOW = mkBasePkgModule pREL_SHOW_Name -pREL_READ = mkBasePkgModule pREL_READ_Name -pREL_ADDR = mkBasePkgModule pREL_ADDR_Name -pREL_WORD = mkBasePkgModule pREL_WORD_Name -pREL_INT = mkBasePkgModule pREL_INT_Name -pREL_PTR = mkBasePkgModule pREL_PTR_Name -pREL_ST = mkBasePkgModule pREL_ST_Name -pREL_STABLE = mkBasePkgModule pREL_STABLE_Name -pREL_IO_BASE = mkBasePkgModule pREL_IO_BASE_Name -pREL_PACK = mkBasePkgModule pREL_PACK_Name -pREL_ERR = mkBasePkgModule pREL_ERR_Name -pREL_NUM = mkBasePkgModule pREL_NUM_Name -pREL_ENUM = mkBasePkgModule pREL_ENUM_Name -pREL_REAL = mkBasePkgModule pREL_REAL_Name -pREL_FLOAT = mkBasePkgModule pREL_FLOAT_Name -pREL_ARR = mkBasePkgModule pREL_ARR_Name -pREL_PARR = mkBasePkgModule pREL_PARR_Name -pREL_BYTEARR = mkBasePkgModule pREL_BYTEARR_Name -pREL_TOP_HANDLER= mkBasePkgModule pREL_TOP_HANDLER_Name -pRELUDE = mkBasePkgModule pRELUDE_Name -sYSTEM_IO = mkBasePkgModule sYSTEM_IO_Name -aDDR = mkBasePkgModule aDDR_Name -aRROW = mkBasePkgModule aRROW_Name -gENERICS = mkBasePkgModule gENERICS_Name -tYPEABLE = mkBasePkgModule tYPEABLE_Name -dOTNET = mkBasePkgModule dOTNET_Name -gLA_EXTS = mkBasePkgModule gLA_EXTS_Name -mONAD_FIX = mkBasePkgModule mONAD_FIX_Name - -rOOT_MAIN_Name = mkModuleName ":Main" -- Root module for initialisation -rOOT_MAIN = mkHomeModule rOOT_MAIN_Name +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_BYTEARR = mkModule "PrelByteArr" +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_FIX = mkModule "Control.Monad.Fix" +aRROW = mkModule "Control.Arrow" +aDDR = mkModule "Addr" + +gLA_EXTS = mkModule "GHC.Exts" +rOOT_MAIN = mkModule ":Main" -- Root module for initialisation -- The ':xxx' makes a moudle 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 = mkHomeModule (mkModuleName ":Interactive") + +iNTERACTIVE = mkModule ":Interactive" \end{code} %************************************************************************ @@ -330,13 +295,13 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main") eq_RDR = nameRdrName eqName ge_RDR = nameRdrName geName -ne_RDR = varQual_RDR pREL_BASE_Name FSLIT("/=") -le_RDR = varQual_RDR pREL_BASE_Name FSLIT("<=") -gt_RDR = varQual_RDR pREL_BASE_Name FSLIT(">") -compare_RDR = varQual_RDR pREL_BASE_Name FSLIT("compare") -ltTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("LT") -eqTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("EQ") -gtTag_RDR = dataQual_RDR pREL_BASE_Name FSLIT("GT") +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") eqClass_RDR = nameRdrName eqClassName numClass_RDR = nameRdrName numClassName @@ -344,8 +309,8 @@ ordClass_RDR = nameRdrName ordClassName enumClass_RDR = nameRdrName enumClassName monadClass_RDR = nameRdrName monadClassName -map_RDR = varQual_RDR pREL_BASE_Name FSLIT("map") -append_RDR = varQual_RDR pREL_BASE_Name FSLIT("++") +map_RDR = varQual_RDR pREL_BASE FSLIT("map") +append_RDR = varQual_RDR pREL_BASE FSLIT("++") foldr_RDR = nameRdrName foldrName build_RDR = nameRdrName buildName @@ -358,8 +323,8 @@ and_RDR = nameRdrName andName left_RDR = nameRdrName leftDataConName right_RDR = nameRdrName rightDataConName -fromEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("fromEnum") -toEnum_RDR = varQual_RDR pREL_ENUM_Name FSLIT("toEnum") +fromEnum_RDR = varQual_RDR pREL_ENUM FSLIT("fromEnum") +toEnum_RDR = varQual_RDR pREL_ENUM FSLIT("toEnum") enumFrom_RDR = nameRdrName enumFromName enumFromTo_RDR = nameRdrName enumFromToName @@ -378,8 +343,8 @@ unpackCStringFoldr_RDR = nameRdrName unpackCStringFoldrName unpackCStringUtf8_RDR = nameRdrName unpackCStringUtf8Name newStablePtr_RDR = nameRdrName newStablePtrName -addrDataCon_RDR = dataQual_RDR aDDR_Name FSLIT("A#") -wordDataCon_RDR = dataQual_RDR pREL_WORD_Name FSLIT("W#") +addrDataCon_RDR = dataQual_RDR aDDR FSLIT("A#") +wordDataCon_RDR = dataQual_RDR pREL_WORD FSLIT("W#") bindIO_RDR = nameRdrName bindIOName returnIO_RDR = nameRdrName returnIOName @@ -387,56 +352,56 @@ returnIO_RDR = nameRdrName returnIOName fromInteger_RDR = nameRdrName fromIntegerName fromRational_RDR = nameRdrName fromRationalName minus_RDR = nameRdrName minusName -times_RDR = varQual_RDR pREL_NUM_Name FSLIT("*") -plus_RDR = varQual_RDR pREL_NUM_Name FSLIT("+") - -compose_RDR = varQual_RDR pREL_BASE_Name FSLIT(".") - -not_RDR = varQual_RDR pREL_BASE_Name FSLIT("not") -getTag_RDR = varQual_RDR pREL_BASE_Name FSLIT("getTag") -succ_RDR = varQual_RDR pREL_ENUM_Name FSLIT("succ") -pred_RDR = varQual_RDR pREL_ENUM_Name FSLIT("pred") -minBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("minBound") -maxBound_RDR = varQual_RDR pREL_ENUM_Name FSLIT("maxBound") -range_RDR = varQual_RDR pREL_ARR_Name FSLIT("range") -inRange_RDR = varQual_RDR pREL_ARR_Name FSLIT("inRange") -index_RDR = varQual_RDR pREL_ARR_Name FSLIT("index") - -readList_RDR = varQual_RDR pREL_READ_Name FSLIT("readList") -readListDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListDefault") -readListPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrec") -readListPrecDefault_RDR = varQual_RDR pREL_READ_Name FSLIT("readListPrecDefault") -readPrec_RDR = varQual_RDR pREL_READ_Name FSLIT("readPrec") -parens_RDR = varQual_RDR pREL_READ_Name FSLIT("parens") -choose_RDR = varQual_RDR pREL_READ_Name FSLIT("choose") -lexP_RDR = varQual_RDR pREL_READ_Name FSLIT("lexP") - -punc_RDR = dataQual_RDR lEX_Name FSLIT("Punc") -ident_RDR = dataQual_RDR lEX_Name FSLIT("Ident") -symbol_RDR = dataQual_RDR lEX_Name FSLIT("Symbol") - -step_RDR = varQual_RDR rEAD_PREC_Name FSLIT("step") -alt_RDR = varQual_RDR rEAD_PREC_Name FSLIT("+++") -reset_RDR = varQual_RDR rEAD_PREC_Name FSLIT("reset") -prec_RDR = varQual_RDR rEAD_PREC_Name FSLIT("prec") - -showList_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList") -showList___RDR = varQual_RDR pREL_SHOW_Name FSLIT("showList__") -showsPrec_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showsPrec") -showString_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showString") -showSpace_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showSpace") -showParen_RDR = varQual_RDR pREL_SHOW_Name FSLIT("showParen") - -typeOf_RDR = varQual_RDR tYPEABLE_Name FSLIT("typeOf") -mkTypeRep_RDR = varQual_RDR tYPEABLE_Name FSLIT("mkTyConApp") -mkTyConRep_RDR = varQual_RDR tYPEABLE_Name FSLIT("mkTyCon") - -undefined_RDR = varQual_RDR pREL_ERR_Name FSLIT("undefined") - -crossDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT(":*:") -inlDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("Inl") -inrDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("Inr") -genUnitDataCon_RDR = dataQual_RDR pREL_BASE_Name FSLIT("Unit") +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") + +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") + +punc_RDR = dataQual_RDR lEX FSLIT("Punc") +ident_RDR = dataQual_RDR lEX FSLIT("Ident") +symbol_RDR = dataQual_RDR lEX FSLIT("Symbol") + +step_RDR = varQual_RDR rEAD_PREC FSLIT("step") +alt_RDR = varQual_RDR rEAD_PREC FSLIT("+++") +reset_RDR = varQual_RDR rEAD_PREC FSLIT("reset") +prec_RDR = varQual_RDR rEAD_PREC FSLIT("prec") + +showList_RDR = varQual_RDR pREL_SHOW FSLIT("showList") +showList___RDR = varQual_RDR pREL_SHOW FSLIT("showList__") +showsPrec_RDR = varQual_RDR pREL_SHOW FSLIT("showsPrec") +showString_RDR = varQual_RDR pREL_SHOW FSLIT("showString") +showSpace_RDR = varQual_RDR pREL_SHOW FSLIT("showSpace") +showParen_RDR = varQual_RDR pREL_SHOW FSLIT("showParen") + +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") + +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") ---------------------- varQual_RDR mod str = mkOrig mod (mkOccFS varName str) diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 46fd3c362b..3616ccbe30 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -35,7 +35,7 @@ import Var ( Id ) import Name ( UserFS, EncodedFS, encodeFS, decode, getOccName, occNameFS ) -import Module ( Module, ModuleName, moduleName ) +import Module ( Module ) import Outputable import FastTypes import FastString @@ -111,13 +111,13 @@ data CostCentre | NormalCC { cc_name :: CcName, -- Name of the cost centre itself - cc_mod :: ModuleName, -- Name of module defining this CC. + cc_mod :: Module, -- Name of module defining this CC. cc_is_dupd :: IsDupdCC, -- see below cc_is_caf :: IsCafCC -- see below } | AllCafsCC { - cc_mod :: ModuleName -- Name of module defining this CC. + cc_mod :: Module -- Name of module defining this CC. } type CcName = EncodedFS @@ -202,17 +202,17 @@ Building cost centres \begin{code} mkUserCC :: UserFS -> Module -> CostCentre mkUserCC cc_name mod - = NormalCC { cc_name = encodeFS cc_name, cc_mod = moduleName mod, + = NormalCC { cc_name = encodeFS cc_name, cc_mod = mod, cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-} } mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre mkAutoCC id mod is_caf - = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = moduleName mod, + = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = mod, cc_is_dupd = OriginalCC, cc_is_caf = is_caf } -mkAllCafsCC m = AllCafsCC { cc_mod = moduleName m } +mkAllCafsCC m = AllCafsCC { cc_mod = m } @@ -253,7 +253,7 @@ sccAbleCostCentre cc | isCafCC cc = False | otherwise = True ccFromThisModule :: CostCentre -> Module -> Bool -ccFromThisModule cc m = cc_mod cc == moduleName m +ccFromThisModule cc m = cc_mod cc == m \end{code} \begin{code} diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 508f812cb0..97aedf223f 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -29,7 +29,7 @@ module SCCfinal ( stgMassageForProfiling ) where import StgSyn -import CmdLineOpts ( opt_AutoSccsOnIndividualCafs ) +import CmdLineOpts ( DynFlags, opt_AutoSccsOnIndividualCafs ) import CostCentre -- lots of things import Id ( Id ) import Module ( Module ) @@ -44,12 +44,13 @@ infixr 9 `thenMM`, `thenMM_` \begin{code} stgMassageForProfiling - :: Module -- module name + :: DynFlags + -> Module -- module name -> UniqSupply -- unique supply -> [StgBinding] -- input -> (CollectedCCs, [StgBinding]) -stgMassageForProfiling mod_name us stg_binds +stgMassageForProfiling dflags mod_name us stg_binds = let ((local_ccs, extern_ccs, cc_stacks), stg_binds2) @@ -100,7 +101,7 @@ stgMassageForProfiling mod_name us stg_binds do_top_rhs :: Id -> StgRhs -> MassageM StgRhs do_top_rhs binder (StgRhsClosure _ bi fv u srt [] (StgSCC cc (StgConApp con args))) - | not (isSccCountCostCentre cc) && not (isDllConApp con args) + | not (isSccCountCostCentre cc) && not (isDllConApp dflags con args) -- Trivial _scc_ around nothing but static data -- Eliminate _scc_ ... and turn into StgRhsCon diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 1ac5485837..f6955261a4 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -46,11 +46,11 @@ import HsTypes ( replaceTyVarName ) import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity ) import TcRnMonad import Name ( Name, nameIsLocalOrFrom, mkInternalName, isInternalName, - nameSrcLoc, nameOccName, nameModuleName, nameParent ) + nameSrcLoc, nameOccName, nameModule, nameParent ) import NameSet import OccName ( tcName, isDataOcc, occNameFlavour, reportIfUnused ) -import Module ( Module, ModuleName, moduleName, mkHomeModule ) -import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE, consDataConKey, hasKey ) +import Module ( Module ) +import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, consDataConKey, hasKey ) import UniqSupply import BasicTypes ( IPName, mapIPName ) import SrcLoc ( SrcSpan, srcSpanStart, Located(..), eqLocated, unLoc, @@ -83,12 +83,12 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) -- very confused indeed. This test rejects code like -- data T = (,) Int Int -- unless we are in GHC.Tup - = do checkErr (isInternalName name || this_mod_name == nameModuleName name) + = do checkErr (isInternalName name || this_mod == nameModule name) (badOrigBinding rdr_name) returnM name | isOrig rdr_name - = do checkErr (rdr_mod_name == this_mod_name || rdr_mod_name == rOOT_MAIN_Name) + = do checkErr (rdr_mod == this_mod || rdr_mod == rOOT_MAIN) (badOrigBinding rdr_name) -- When reading External Core we get Orig names as binders, -- but they should agree with the module gotten from the monad @@ -107,14 +107,13 @@ newTopSrcBinder this_mod mb_parent (L loc rdr_name) -- the RdrName, not from the environment. In principle, it'd be fine to -- have an arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - newGlobalBinder (mkHomeModule rdr_mod_name) (rdrNameOcc rdr_name) mb_parent + newGlobalBinder rdr_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) --TODO, should pass the whole span | otherwise = newGlobalBinder this_mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) where - this_mod_name = moduleName this_mod - rdr_mod_name = rdrNameModule rdr_name + rdr_mod = rdrNameModule rdr_name \end{code} %********************************************************* @@ -166,7 +165,7 @@ lookupTopBndrRn rdr_name -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name = do { loc <- getSrcSpanM - ; newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) + ; newGlobalBinder (rdrNameModule rdr_name) (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) } | otherwise @@ -427,7 +426,7 @@ lookupFixityRn name returnM (mi_fix_fn iface (nameOccName name)) where doc = ptext SLIT("Checking fixity for") <+> ppr name - name_mod = nameModuleName name + name_mod = nameModule name dataTcOccs :: RdrName -> [RdrName] -- If the input is a data constructor, return both it and a type @@ -671,7 +670,7 @@ mapFvRn f xs = mappM f xs `thenM` \ stuff -> %************************************************************************ \begin{code} -warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM () +warnUnusedModules :: [(Module,SrcSpan)] -> RnM () warnUnusedModules mods = ifOptM Opt_WarnUnusedImports (mappM_ bleat mods) where diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 4dfcc13eea..9b172cfabd 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -23,14 +23,12 @@ import LoadIface ( loadSrcInterface ) import TcRnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, isUnboundName, - main_RDR_Unqual ) -import Module ( Module, ModuleName, moduleName, mkPackageModule, - moduleNameUserString, isHomeModule, - unitModuleEnvByName, unitModuleEnv, - lookupModuleEnvByName, moduleEnvElts ) -import Name ( Name, nameSrcLoc, nameOccName, nameModuleName, isWiredInName, - nameParent, nameParent_maybe, isExternalName, nameModule, +import PrelNames ( pRELUDE, isUnboundName, main_RDR_Unqual ) +import Module ( Module, moduleUserString, + unitModuleEnv, unitModuleEnv, + lookupModuleEnv, moduleEnvElts ) +import Name ( Name, nameSrcLoc, nameOccName, nameModule, isWiredInName, + nameParent, nameParent_maybe, isExternalName, isBuiltInSyntax ) import NameSet import OccName ( srcDataName, isTcOcc, occNameFlavour, OccEnv, @@ -38,8 +36,9 @@ import OccName ( srcDataName, isTcOcc, occNameFlavour, OccEnv, import HscTypes ( GenAvailInfo(..), AvailInfo, Avails, GhciMode(..), IfaceExport, HomePackageTable, PackageIfaceTable, availName, availNames, availsToNameSet, unQualInScope, - Deprecs(..), ModIface(..), Dependencies(..), lookupIface, - ExternalPackageState(..) + Deprecs(..), ModIface(..), Dependencies(..), + lookupIface, ExternalPackageState(..), + IfacePackage(..) ) import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), @@ -102,7 +101,7 @@ rnImports imports -- because the former doesn't even look at Prelude.hi for instance -- declarations, whereas the latter does. mk_prel_imports this_mod no_prelude - | moduleName this_mod == pRELUDE_Name + | this_mod == pRELUDE || explicit_prelude_import || no_prelude = [] @@ -111,11 +110,11 @@ rnImports imports explicit_prelude_import = notNull [ () | L _ (ImportDecl mod _ _ _ _) <- imports, - unLoc mod == pRELUDE_Name ] + unLoc mod == pRELUDE ] preludeImportDecl = L loc $ - ImportDecl (L loc pRELUDE_Name) + ImportDecl (L loc pRELUDE) False {- Not a boot interface -} False {- Not qualified -} Nothing {- No "as" -} @@ -138,7 +137,6 @@ importsFromImportDecl this_mod -- file not found) we get lots of spurious errors from 'filterImports' let imp_mod_name = unLoc loc_imp_mod_name - this_mod_name = moduleName this_mod doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") in loadSrcInterface doc imp_mod_name want_boot `thenM` \ iface -> @@ -160,7 +158,7 @@ importsFromImportDecl this_mod deps = mi_deps iface filtered_exports = filter not_this_mod (mi_exports iface) - not_this_mod (mod,_) = mod /= this_mod_name + not_this_mod (mod,_) = mod /= this_mod -- If the module exports anything defined in this module, just ignore it. -- Reason: otherwise it looks as if there are two local definition sites -- for the thing, and an error gets reported. Easiest thing is just to @@ -190,6 +188,8 @@ importsFromImportDecl this_mod filterImports iface imp_spec imp_details total_avails `thenM` \ (avail_env, gbl_env) -> + getDOpts `thenM` \ dflags -> + let -- Compute new transitive dependencies @@ -198,23 +198,27 @@ importsFromImportDecl this_mod | otherwise = dep_orphs deps (dependent_mods, dependent_pkgs) - | isHomeModule imp_mod - = -- Imported module is from the home package + = case mi_package iface of + ThisPackage -> + -- Imported module is from the home package -- Take its dependent modules and add imp_mod itself -- Take its dependent packages unchanged - -- NB: (dep_mods deps) might include a hi-boot file for the module being - -- compiled, CM. Do *not* filter this out (as we used to), because when - -- we've finished dealing with the direct imports we want to know if any - -- of them depended on CM.hi-boot, in which case we should do the hi-boot - -- consistency check. See LoadIface.loadHiBootInterface - ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps) - - | otherwise - = -- Imported module is from another package + -- + -- NB: (dep_mods deps) might include a hi-boot file + -- for the module being compiled, CM. Do *not* filter + -- this out (as we used to), because when we've + -- finished dealing with the direct imports we want to + -- know if any of them depended on CM.hi-boot, in + -- which case we should do the hi-boot consistency + -- check. See LoadIface.loadHiBootInterface + ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps) + + ExternalPackage pkg -> + -- Imported module is from another package -- Dump the dependent modules -- Add the package imp_mod comes from to the dependent packages - ASSERT( not (mi_package iface `elem` dep_pkgs deps) ) - ([], mi_package iface : dep_pkgs deps) + ASSERT2( not (pkg `elem` dep_pkgs deps), ppr pkg <+> ppr (dep_pkgs deps) ) + ([], pkg : dep_pkgs deps) import_all = case imp_details of Just (is_hiding, ls) -- Imports are spec'd explicitly @@ -227,7 +231,7 @@ importsFromImportDecl this_mod -- module M ( module P ) where ... -- Then we must export whatever came from P unqualified. imports = ImportAvails { - imp_qual = unitModuleEnvByName qual_mod_name avail_env, + imp_qual = unitModuleEnv qual_mod_name avail_env, imp_env = avail_env, imp_mods = unitModuleEnv imp_mod (imp_mod, import_all, loc), imp_orphs = orphans, @@ -250,13 +254,12 @@ exportsToAvails exports ; return (concat avails_by_module) } where do_one (mod_name, exports) = mapM (do_avail mod_name) exports - do_avail mod_nm (Avail n) = do { n' <- lookupOrig mod_nm n; + do_avail mod (Avail n) = do { n' <- lookupOrig mod n; ; return (Avail n') } - do_avail mod_nm (AvailTC n ns) = do { n' <- lookupOrig mod_nm n + do_avail mod (AvailTC n ns) = do { n' <- lookupOrig mod n ; ns' <- mappM (lookup_sub n') ns ; return (AvailTC n' ns') } where - mod = mkPackageModule mod_nm -- Not necessarily right yet lookup_sub parent occ = newGlobalBinder mod occ (Just parent) noSrcLoc -- Hack alert! Notice the newGlobalBinder. It ensures that the subordinate -- names record their parent; and that in turn ensures that the GlobalRdrEnv @@ -310,8 +313,7 @@ importsFromLocalDecls group doptM Opt_NoImplicitPrelude `thenM` \ implicit_prelude -> let - mod_name = moduleName this_mod - prov = LocalDef mod_name + prov = LocalDef this_mod gbl_env = mkGlobalRdrEnv gres gres = [ GRE { gre_name = name, gre_prov = prov} | name <- all_names] @@ -571,7 +573,7 @@ it re-exports @GHC@, which includes @takeMVar#@, whose type includes \begin{code} type ExportAccum -- The type of the accumulating parameter of -- the main worker function in exportsFromAvail - = ([ModuleName], -- 'module M's seen so far + = ([Module], -- 'module M's seen so far ExportOccMap, -- Tracks exported occurrence names NameSet) -- The accumulated exported stuff emptyExportAccum = ([], emptyOccEnv, emptyNameSet) @@ -635,7 +637,7 @@ exports_from_avail (Just export_items) rdr_env returnM acc } | otherwise - = case lookupModuleEnvByName mod_avail_env mod of + = case lookupModuleEnv mod_avail_env mod of Nothing -> addErr (modExportErr mod) `thenM_` returnM acc @@ -745,7 +747,7 @@ reportDeprecations tcg_env (parens imp_msg), (ppr deprec_txt) ]) where - name_mod = nameModuleName name + name_mod = nameModule name imp_mod = is_mod imp_spec imp_msg = ptext SLIT("imported from") <+> ppr imp_mod <> extra extra | imp_mod == name_mod = empty @@ -836,7 +838,7 @@ reportUnusedNames gbl_env -- To figure out the minimal set of imports, start with the things -- that are in scope (i.e. in gbl_env). Then just combine them -- into a bunch of avails, so they are properly grouped - minimal_imports :: FiniteMap ModuleName AvailEnv + minimal_imports :: FiniteMap Module AvailEnv minimal_imports0 = emptyFM minimal_imports1 = foldr add_name minimal_imports0 defined_and_used minimal_imports = foldr add_inst_mod minimal_imports1 direct_import_mods @@ -870,10 +872,9 @@ reportUnusedNames gbl_env | otherwise = Avail n add_inst_mod (mod,_,_) acc - | mod_name `elemFM` acc = acc -- We import something already - | otherwise = addToFM acc mod_name emptyAvailEnv + | mod `elemFM` acc = acc -- We import something already + | otherwise = addToFM acc mod emptyAvailEnv where - mod_name = moduleName mod -- Add an empty collection of imports for a module -- from which we have sucked only instance decls @@ -887,16 +888,15 @@ reportUnusedNames gbl_env -- that are not mentioned in minimal_imports1 -- [Note: not 'minimal_imports', because that includes directly-imported -- modules even if we use nothing from them; see notes above] - unused_imp_mods = [(mod_name,loc) | (mod,imp,loc) <- direct_import_mods, - let mod_name = moduleName mod, - not (mod_name `elemFM` minimal_imports1), - mod_name /= pRELUDE_Name, + unused_imp_mods = [(mod,loc) | (mod,imp,loc) <- direct_import_mods, + not (mod `elemFM` minimal_imports1), + mod /= pRELUDE, imp /= Just False] -- The Just False part is not to complain about -- import M (), which is an idiom for importing -- instance declarations - module_unused :: ModuleName -> Bool + module_unused :: Module -> Bool module_unused mod = any (((==) mod) . fst) unused_imp_mods --------------------- @@ -910,7 +910,7 @@ warnDuplicateImports gres -- ToDo: deal with original imports with 'qualified' and 'as M' clauses -printMinimalImports :: FiniteMap ModuleName AvailEnv -- Minimal imports +printMinimalImports :: FiniteMap Module AvailEnv -- Minimal imports -> RnM () printMinimalImports imps = ifOptM Opt_D_dump_minimal_imports $ do { @@ -923,9 +923,9 @@ printMinimalImports imps (vcat (map ppr_mod_ie mod_ies)) }) } where - mkFilename this_mod = moduleNameUserString (moduleName this_mod) ++ ".imports" + mkFilename this_mod = moduleUserString this_mod ++ ".imports" ppr_mod_ie (mod_name, ies) - | mod_name == pRELUDE_Name + | mod_name == pRELUDE = empty | null ies -- Nothing except instances comes from here = ptext SLIT("import") <+> ppr mod_name <> ptext SLIT("() -- Instances only") @@ -956,7 +956,7 @@ printMinimalImports imps where all_used avail_occs = all (`elem` map nameOccName ns) avail_occs doc = text "Compute minimal imports from" <+> ppr n - n_mod = nameModuleName n + n_mod = nameModule n \end{code} diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index ba34b0c0af..4e77ca9643 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -262,7 +262,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) text "Imported rules", pprRuleBase imp_rule_base]) #ifdef DEBUG - ; let bad_rules = filter (idIsFrom (mg_mod guts)) + ; let bad_rules = filter (idIsFrom (mg_module guts)) (varSetElems (ruleBaseIds imp_rule_base)) ; WARN( not (null bad_rules), ppr bad_rules ) return () #endif diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index dc945f52be..bdb8c761c8 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -74,7 +74,7 @@ stg2stg dflags module_name binds _scc_ "ProfMassage" let (collected_CCs, binds3) - = stgMassageForProfiling module_name us1 binds + = stgMassageForProfiling dflags module_name us1 binds in end_pass us2 "ProfMassage" collected_CCs binds3 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 61e67df57c..9397af6c74 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -142,7 +142,7 @@ for x, solely to put in the SRTs lower down. coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding] coreToStg dflags pgm = return pgm' - where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm + where (_, _, pgm') = coreTopBindsToStg dflags emptyVarEnv pgm coreExprToStg :: CoreExpr -> StgExpr coreExprToStg expr @@ -150,33 +150,35 @@ coreExprToStg expr coreTopBindsToStg - :: IdEnv HowBound -- environment for the bindings + :: DynFlags + -> IdEnv HowBound -- environment for the bindings -> [CoreBind] -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) -coreTopBindsToStg env [] = (env, emptyFVInfo, []) -coreTopBindsToStg env (b:bs) +coreTopBindsToStg dflags env [] = (env, emptyFVInfo, []) +coreTopBindsToStg dflags env (b:bs) = (env2, fvs2, b':bs') where -- env accumulates down the list of binds, fvs accumulates upwards - (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b - (env2, fvs1, bs') = coreTopBindsToStg env1 bs + (env1, fvs2, b' ) = coreTopBindToStg dflags env fvs1 b + (env2, fvs1, bs') = coreTopBindsToStg dflags env1 bs coreTopBindToStg - :: IdEnv HowBound + :: DynFlags + -> IdEnv HowBound -> FreeVarsInfo -- Info about the body -> CoreBind -> (IdEnv HowBound, FreeVarsInfo, StgBinding) -coreTopBindToStg env body_fvs (NonRec id rhs) +coreTopBindToStg dflags 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 body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> + coreToTopStgRhs dflags body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> returnLne (stg_rhs, fvs') ) @@ -187,7 +189,7 @@ coreTopBindToStg env body_fvs (NonRec id rhs) -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) (env', fvs' `unionFVInfo` body_fvs, bind) -coreTopBindToStg env body_fvs (Rec pairs) +coreTopBindToStg dflags env body_fvs (Rec pairs) = let (binders, rhss) = unzip pairs @@ -197,7 +199,7 @@ coreTopBindToStg env body_fvs (Rec pairs) (stg_rhss, fvs') = initLne env' ( - mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs + mapAndUnzipLne (coreToTopStgRhs dflags body_fvs) pairs `thenLne` \ (stg_rhss, fvss') -> let fvs' = unionFVInfos fvss' in returnLne (stg_rhss, fvs') @@ -229,17 +231,18 @@ consistentCafInfo id bind \begin{code} coreToTopStgRhs - :: FreeVarsInfo -- Free var info for the scope of the binding + :: DynFlags + -> FreeVarsInfo -- Free var info for the scope of the binding -> (Id,CoreExpr) -> LneM (StgRhs, FreeVarsInfo) -coreToTopStgRhs scope_fv_info (bndr, rhs) +coreToTopStgRhs dflags 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 rhs + is_static = rhsIsStatic dflags rhs mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index a6f1868b6e..9c1c5466c2 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -51,7 +51,7 @@ import VarSet ( IdSet, isEmptyVarSet ) import Var ( isId ) import Id ( Id, idName, idType, idCafInfo ) import IdInfo ( mayHaveCafRefs ) -import Name ( isDllName ) +import Packages ( isDllName ) import Literal ( Literal, literalType ) import ForeignCall ( ForeignCall ) import DataCon ( DataCon, dataConName ) @@ -65,7 +65,7 @@ import TyCon ( TyCon ) import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet ) import Unique ( Unique ) import Bitmap -import CmdLineOpts ( opt_SccProfilingOn ) +import CmdLineOpts ( DynFlags, opt_SccProfilingOn ) \end{code} %************************************************************************ @@ -104,17 +104,18 @@ data GenStgArg occ isStgTypeArg (StgTypeArg _) = True isStgTypeArg other = False -isDllArg :: StgArg -> Bool +isDllArg :: DynFlags -> StgArg -> Bool -- Does this argument refer to something in a different DLL? -isDllArg (StgTypeArg v) = False -isDllArg (StgVarArg v) = isDllName (idName v) -isDllArg (StgLitArg lit) = False +isDllArg dflags (StgTypeArg v) = False +isDllArg dflags (StgVarArg v) = isDllName dflags (idName v) +isDllArg dflags (StgLitArg lit) = False -isDllConApp :: DataCon -> [StgArg] -> Bool +isDllConApp :: DynFlags -> DataCon -> [StgArg] -> Bool -- Does this constructor application refer to -- anything in a different DLL? -- If so, we can't allocate it statically -isDllConApp con args = isDllName (dataConName con) || any isDllArg args +isDllConApp dflags con args + = isDllName dflags (dataConName con) || any (isDllArg dflags) args stgArgType :: StgArg -> Type -- Very half baked becase we have lost the type arguments diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 93e83f4487..f30ebcb713 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -69,12 +69,13 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, import Type ( substTy, substTys, substTyWith, substTheta, zipTopTvSubst ) import Unify ( matchTys ) import Kind ( isSubKind ) +import Packages ( isHomeModule ) import HscTypes ( ExternalPackageState(..) ) import CoreFVs ( idFreeTyVars ) import DataCon ( DataCon, dataConTyVars, dataConStupidTheta, dataConName ) import Id ( Id, idName, idType, mkUserLocal, mkLocalId ) import PrelInfo ( isStandardClass, isNoDictClass ) -import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, isHomePackageName, +import Name ( Name, mkMethodOcc, getOccName, getSrcLoc, nameModule, isInternalName, setNameUnique, mkSystemNameEncoded ) import NameSet ( addOneToNameSet ) import Literal ( inIntRange ) @@ -741,14 +742,15 @@ instantiate_dfun tenv dfun_id pred loc in returnM (GenInst dicts rhs) -record_dfun_usage dfun_id - | isInternalName dfun_name = return () -- From this module - | not (isHomePackageName dfun_name) = return () -- From another package package - | otherwise = getGblEnv `thenM` \ tcg_env -> - updMutVar (tcg_inst_uses tcg_env) +record_dfun_usage dfun_id = do + dflags <- getDOpts + let dfun_name = idName dfun_id + dfun_mod = nameModule dfun_name + if isInternalName dfun_name || not (isHomeModule dflags dfun_mod) + then return () -- internal, or in another package + else do tcg_env <- getGblEnv + updMutVar (tcg_inst_uses tcg_env) (`addOneToNameSet` idName dfun_id) - where - dfun_name = idName dfun_id tcGetInstEnvs :: TcM (InstEnv, InstEnv) -- Gets both the external-package inst-env diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 1e5576728c..8f8168bc94 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -1013,7 +1013,7 @@ gen_Typeable_binds tycon mk_typeOf_RDR :: TyCon -> RdrName -- Use the arity of the TyCon to make the right typeOfn function -mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_Name (mkFastString ("typeOf" ++ suffix)) +mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix)) where arity = tyConArity tycon suffix | arity == 0 = "" @@ -1147,15 +1147,15 @@ gen_Data_binds fix_env tycon fixity | is_infix = infix_RDR | otherwise = prefix_RDR -gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl") -gunfold_RDR = varQual_RDR gENERICS_Name FSLIT("gunfold") -toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr") -dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf") -mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr") -mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType") -conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("constrIndex") -prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix") -infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix") +gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl") +gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold") +toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr") +dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf") +mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr") +mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType") +conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex") +prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix") +infix_RDR = dataQual_RDR gENERICS FSLIT("Infix") \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index c981b99d1c..17c3cf36b3 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -21,12 +21,14 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) +import Packages ( moduleToPackageConfig, mkPackageId, package, + isHomeModule ) import DriverState ( v_MainModIs, v_MainFunIs ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..), nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) -import PrelNames ( runIOName, rootMainName, mAIN_Name, +import PrelNames ( runIOName, rootMainName, mAIN, main_RDR_Unqual ) import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, plusGlobalRdrEnv ) @@ -45,7 +47,6 @@ import TcIface ( tcExtCoreBindings ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import LoadIface ( loadOrphanModules, loadHiBootInterface ) -import IfaceEnv ( lookupOrig ) import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) @@ -56,7 +57,7 @@ import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) import Id ( mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) -import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts ) +import Module ( mkModule, moduleEnvElts ) import OccName ( mkVarOcc ) import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet @@ -110,10 +111,10 @@ import IdInfo ( GlobalIdDetails(..) ) import SrcLoc ( interactiveSrcLoc, unLoc ) import Kind ( Kind ) import Var ( globaliseId ) -import Name ( nameOccName, nameModuleName ) +import Name ( nameOccName, nameModule ) import NameEnv ( delListFromNameEnv ) import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName ) -import Module ( ModuleName, lookupModuleEnvByName ) +import Module ( Module, lookupModuleEnv ) import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ), HomeModInfo(..), typeEnvElts, typeEnvClasses, availNames, icPrintUnqual, @@ -151,14 +152,17 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_mod = case maybe_mod of - Nothing -> mkHomeModule mAIN_Name + Nothing -> mAIN -- 'module M where' is omitted Just (L _ mod) -> mod } ; -- The normal case initTc hsc_env this_mod $ setSrcSpan loc $ - do { -- Deal with imports; sets tcg_rdr_env, tcg_imports + do { + checkForPackageModule (hsc_dflags hsc_env) this_mod; + + -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; -- Record boot-file info in the EPS, so that it's @@ -216,6 +220,22 @@ tcRnModule hsc_env (L loc (HsModule maybe_mod exports tcDump final_env ; return final_env }}}} + +-- This is really a sanity check that the user has given -package-name +-- if necessary. -package-name is only necessary when the package database +-- already contains the current package, because then we can't tell +-- whether a given module is in the current package or not, without knowing +-- the name of the current package. +checkForPackageModule dflags this_mod + | not (isHomeModule dflags this_mod), + Just (pkg,_) <- moduleToPackageConfig dflags this_mod = + let + ppr_pkg = ppr (mkPackageId (package pkg)) + in + addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+> + ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$ + ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.') + | otherwise = return () \end{code} @@ -608,8 +628,8 @@ checkMain mb_main_mod <- readMutVar v_MainModIs ; mb_main_fn <- readMutVar v_MainFunIs ; let { main_mod = case mb_main_mod of { - Just mod -> mkModuleName mod ; - Nothing -> mAIN_Name } ; + Just mod -> mkModule mod ; + Nothing -> mAIN } ; main_fn = case mb_main_fn of { Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; Nothing -> main_RDR_Unqual } } ; @@ -624,7 +644,7 @@ check_main ghci_mode tcg_env main_mod main_fn -- -- -- Blimey: a whole page of code to do this... - | mod_name /= main_mod + | mod /= main_mod = return tcg_env | otherwise @@ -654,7 +674,7 @@ check_main ghci_mode tcg_env main_mod main_fn }) }}} where - mod_name = moduleName (tcg_mod tcg_env) + mod = tcg_mod tcg_env complain_no_main | ghci_mode == Interactive = return () | otherwise = failWithTc noMainMsg @@ -933,7 +953,7 @@ tcRnType hsc_env ictxt rdr_type \begin{code} #ifdef GHCI -mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only +mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only -> IO GlobalRdrEnv mkExportEnv hsc_env exports = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $ @@ -944,7 +964,7 @@ mkExportEnv hsc_env exports -- Some error; initTc will have printed it } -getModuleExports :: ModuleName -> TcM GlobalRdrEnv +getModuleExports :: Module -> TcM GlobalRdrEnv getModuleExports mod = do { iface <- load_iface mod ; loadOrphanModules (dep_orphs (mi_deps iface)) @@ -955,7 +975,7 @@ getModuleExports mod | avail <- avails, name <- availNames avail ] } ; returnM (mkGlobalRdrEnv gres) } -vanillaProv :: ModuleName -> Provenance +vanillaProv :: Module -> Provenance -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module vanillaProv mod = Imported [ImportSpec mod mod False @@ -966,7 +986,7 @@ vanillaProv mod = Imported [ImportSpec mod mod False getModuleContents :: HscEnv -> InteractiveContext - -> ModuleName -- Module to inspect + -> Module -- Module to inspect -> Bool -- Grab just the exports, or the whole toplev -> IO (Maybe [IfaceDecl]) @@ -977,7 +997,7 @@ getModuleContents hsc_env ictxt mod exports_only | not exports_only -- We want the whole top-level type env -- so it had better be a home module = do { hpt <- getHpt - ; case lookupModuleEnvByName hpt mod of + ; case lookupModuleEnv hpt mod of Just mod_info -> return (map toIfaceDecl $ filter wantToSee $ typeEnvElts $ @@ -1115,7 +1135,7 @@ toIfaceDecl thing emptyNameSet -- Show data cons ext_nm (munge thing) where - ext_nm n = ExtPkg (nameModuleName n) (nameOccName n) + ext_nm n = ExtPkg (nameModule n) (nameOccName n) -- munge transforms a thing to it's "parent" thing munge (ADataCon dc) = ATyCon (dataConTyCon dc) diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index acbda80b0f..727134fa61 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -1,4 +1,4 @@ - \begin{code} +\begin{code} module TcRnMonad( module TcRnMonad, module TcRnTypes, @@ -17,7 +17,7 @@ import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), ModDetails(..), HomeModInfo(..), Deprecs(..), FixityEnv, FixItem, GhciMode, lookupType, unQualInScope ) -import Module ( Module, ModuleName, unitModuleEnv, foldModuleEnv ) +import Module ( Module, unitModuleEnv, foldModuleEnv ) import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, LocalRdrEnv, emptyLocalRdrEnv ) import Name ( Name, isInternalName ) @@ -34,7 +34,6 @@ import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( NameSet, emptyDUs, emptyNameSet, unionNameSets, addOneToNameSet ) import OccName ( emptyOccEnv ) -import Module ( moduleName ) import Bag ( emptyBag ) import Outputable import UniqSupply ( UniqSupply, mkSplitUniqSupply, uniqFromSupply, splitUniqSupply ) @@ -851,7 +850,7 @@ initIfaceExtCore thing_inside ; let { mod = tcg_mod tcg_env ; if_env = IfGblEnv { if_rec_types = Just (mod, return (tcg_type_env tcg_env)) } - ; if_lenv = IfLclEnv { if_mod = moduleName mod, + ; if_lenv = IfLclEnv { if_mod = mod, if_tv_env = emptyOccEnv, if_id_env = emptyOccEnv } } @@ -873,7 +872,7 @@ initIfaceTc :: HscEnv -> ModIface initIfaceTc hsc_env iface do_this = do { tc_env_var <- newIORef emptyTypeEnv ; let { gbl_env = IfGblEnv { if_rec_types = Just (mod, readMutVar tc_env_var) } ; - ; if_lenv = IfLclEnv { if_mod = moduleName mod, + ; if_lenv = IfLclEnv { if_mod = mod, if_tv_env = emptyOccEnv, if_id_env = emptyOccEnv } } @@ -895,7 +894,7 @@ initIfaceRules hsc_env guts do_this ; initTcRnIf 'i' hsc_env gbl_env () do_this } -initIfaceLcl :: ModuleName -> IfL a -> IfM lcl a +initIfaceLcl :: Module -> IfL a -> IfM lcl a initIfaceLcl mod thing_inside = setLclEnv (IfLclEnv { if_mod = mod, if_tv_env = emptyOccEnv, diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index df7dc46bc2..055a2dd185 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -47,7 +47,7 @@ import HscTypes ( FixityEnv, HscEnv, TypeEnv, TyThing, GenAvailInfo(..), AvailInfo, availName, IsBootInterface, Deprecations ) -import Packages ( PackageName ) +import Packages ( PackageId ) import Type ( Type, TvSubstEnv ) import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes ) @@ -230,7 +230,7 @@ data IfLclEnv -- The module for the current IfaceDecl -- So if we see f = \x -> x -- it means M.f = \x -> x, where M is the if_mod - if_mod :: ModuleName, + if_mod :: Module, if_tv_env :: OccEnv TyVar, -- Nested tyvar bindings if_id_env :: OccEnv Id -- Nested id binding @@ -489,29 +489,30 @@ data ImportAvails -- need to recompile if the module version changes -- (b) to specify what child modules to initialise - imp_dep_mods :: ModuleEnv (ModuleName, IsBootInterface), + imp_dep_mods :: ModuleEnv (Module, IsBootInterface), -- Home-package modules needed by the module being compiled -- - -- It doesn't matter whether any of these dependencies are actually - -- *used* when compiling the module; they are listed if they are below - -- it at all. For example, suppose M imports A which imports X. Then - -- compiling M might not need to consult X.hi, but X is still listed - -- in M's dependencies. - - imp_dep_pkgs :: [PackageName], + -- It doesn't matter whether any of these dependencies + -- are actually *used* when compiling the module; they + -- are listed if they are below it at all. For + -- example, suppose M imports A which imports X. Then + -- compiling M might not need to consult X.hi, but X + -- is still listed in M's dependencies. + + imp_dep_pkgs :: [PackageId], -- Packages needed by the module being compiled, whether -- directly, or via other modules in this package, or via -- modules imported from other packages. - imp_orphs :: [ModuleName] + imp_orphs :: [Module] -- Orphan modules below us in the import tree } -mkModDeps :: [(ModuleName, IsBootInterface)] - -> ModuleEnv (ModuleName, IsBootInterface) +mkModDeps :: [(Module, IsBootInterface)] + -> ModuleEnv (Module, IsBootInterface) mkModDeps deps = foldl add emptyModuleEnv deps where - add env elt@(m,_) = extendModuleEnvByName env m elt + add env elt@(m,_) = extendModuleEnv env m elt emptyImportAvails :: ImportAvails emptyImportAvails = ImportAvails { imp_env = emptyAvailEnv, diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index de0d62082d..f4039273fb 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -40,7 +40,7 @@ import NameEnv ( lookupNameEnv ) import HscTypes ( lookupType, ExternalPackageState(..) ) import OccName import Var ( Id, TyVar, idType ) -import Module ( moduleUserString, mkModuleName ) +import Module ( moduleUserString, mkModule ) import TcRnMonad import IfaceEnv ( lookupOrig ) import Class ( Class, classExtraBigSig ) @@ -456,7 +456,7 @@ reify th_name lookupThName :: TH.Name -> TcM Name lookupThName (TH.Name occ (TH.NameG th_ns mod)) - = lookupOrig (mkModuleName (TH.modString mod)) + = lookupOrig (mkModule (TH.modString mod)) (OccName.mkOccName ghc_ns (TH.occString occ)) where ghc_ns = case th_ns of diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 61b1a0f470..2465364c82 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -18,7 +18,7 @@ import DataCon ( DataCon, dataConOrigArgTys, isVanillaDataCon, import TyCon ( TyCon, tyConName, tyConDataCons, isBoxedTupleTyCon ) -import Name ( nameModuleName, nameOccName, getSrcLoc ) +import Name ( nameModule, nameOccName, getSrcLoc ) import OccName ( mkGenOcc1, mkGenOcc2 ) import RdrName ( RdrName, getRdrName, mkVarUnqual, mkOrig ) import BasicTypes ( EP(..), Boxity(..) ) @@ -392,7 +392,7 @@ mkGenericNames tycon where tc_name = tyConName tycon tc_occ = nameOccName tc_name - tc_mod = nameModuleName tc_name + tc_mod = nameModule tc_name from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) \end{code} diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 8b52867677..c8345fb6bf 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -51,7 +51,7 @@ module Outputable ( #include "HsVersions.h" -import {-# SOURCE #-} Module( ModuleName ) +import {-# SOURCE #-} Module( Module ) import {-# SOURCE #-} OccName( OccName ) import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) @@ -91,7 +91,7 @@ data Depth = AllTheWay | PartWay Int -- 0 => stop -type PrintUnqualified = ModuleName -> OccName -> Bool +type PrintUnqualified = Module -> OccName -> Bool -- This function tells when it's ok to print -- a (Global) name unqualified diff --git a/ghc/configure.ac b/ghc/configure.ac index cc5eaa13ae..c7728203f5 100644 --- a/ghc/configure.ac +++ b/ghc/configure.ac @@ -1,5 +1,5 @@ # Initialise and check sanity. -AC_INIT([The Glorious Glasgow Haskell Compilation System], [6.3], [glasgow-haskell-bugs@haskell.org], [ghc]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [6.3.20041114], [glasgow-haskell-bugs@haskell.org], [ghc]) AC_CONFIG_SRCDIR([ghc.spec.in]) # duplicate from ../configure.ac diff --git a/ghc/lib/compat/Makefile b/ghc/lib/compat/Makefile index e6bf14a3ef..b137203215 100644 --- a/ghc/lib/compat/Makefile +++ b/ghc/lib/compat/Makefile @@ -34,10 +34,23 @@ EXCLUDED_SRCS += \ Distribution/Version.hs endif +# Some explicit dependencies +Data/Version.$(way_)o : $(FPTOOLS_TOP)/libraries/base/Data/Version.hs +System/FilePath.$(way_)o : $(FPTOOLS_TOP)/libraries/base/System/FilePath.hs +Distribution/Compat/Error.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Compat/Error.hs +Distribution/Compat/ReadP.$(way_) : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Compat/ReadP.hs +Distribution/Extension.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Extension.hs +Distribution/InstalledPackageInfo.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/InstalledPackageInfo.hs +Distribution/License.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/License.hs +Distribution/Package.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Package.hs +Distribution/ParseUtils.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/ParseUtils.hs +Distribution/Setup.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Setup.hs +Distribution/Version.$(way_)o : $(FPTOOLS_TOP)/libraries/Cabal/Distribution/Version.hs + # Make the #includes in the stubs independent of the current location SRC_HC_OPTS += -I$(FPTOOLS_TOP)/libraries -SRC_HC_OPTS += -fglasgow-exts +SRC_HC_OPTS += -fglasgow-exts -no-recomp ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32" Compat/Directory_HC_OPTS += -\#include shlobj.h diff --git a/ghc/rts/package.conf.in b/ghc/rts/package.conf.in index 736452a303..b1df8ebae8 100644 --- a/ghc/rts/package.conf.in +++ b/ghc/rts/package.conf.in @@ -1,29 +1,35 @@ +/* The RTS is just another package! */ + #include "ghcconfig.h" #include "RtsConfig.h" -/* The RTS is just another package! */ -Package { - name = "rts", - import_dirs = [], - source_dirs = [], +name: rts +version: 1.0 +license: BSD3 +maintainer: glasgow-haskell-users@haskell.org +exposed: True + +exposed-modules: +hidden-modules: + +import-dirs: #ifdef INSTALLING - library_dirs = [ "$libdir" +library-dirs: "$libdir" # ifdef mingw32_TARGET_OS - /* force the dist-provided gcc-lib/ into scope. */ - , "$libdir/gcc-lib" + , "$libdir/gcc-lib" + /* force the dist-provided gcc-lib/ into scope. */ # endif #else /* !INSTALLING */ - library_dirs = [ "$libdir/ghc/rts" +library-dirs: "$libdir/ghc/rts" # ifndef HAVE_LIBGMP - , "$libdir/ghc/rts/gmp" + , "$libdir/ghc/rts/gmp" # endif #endif - ], - hs_libraries = [ "HSrts" ], - extra_libraries = [ - "m" /* for ldexp() */ +hs-libraries: "HSrts" + +extra-libs: "m" /* for ldexp() */ #ifndef HAVE_FRAMEWORK_HASKELLSUPPORT , "gmp" #ifdef HAVE_LIBDL @@ -44,26 +50,22 @@ Package { ,"mingwex" # endif #endif - ], #ifdef INSTALLING - include_dirs = [ "$libdir/include" +include-dirs: "$libdir/include" # ifdef mingw32_TARGET_OS - , "$libdir/include/mingw" + , "$libdir/include/mingw" # endif - ], #else /* !INSTALLING */ - include_dirs = [ "$libdir/ghc/includes" ], +include-dirs: "$libdir/ghc/includes" #endif - c_includes = [ "Stg.h" ], - package_deps = [], - extra_ghc_opts = [], - extra_cc_opts = [], - /* the RTS forward-references to a bunch of stuff in the prelude, - so we force it to be included with special options to ld. */ - extra_ld_opts = - [ +includes: Stg.h +depends: +extra-hugs-opts: +extra-cc-opts: + +extra-ld-opts: #ifdef LEADING_UNDERSCORE "-u", "_GHCziBase_Izh_static_info" , "-u", "_GHCziBase_Czh_static_info" @@ -133,8 +135,15 @@ Package { , "-u", "GHCziWeak_runFinalizzerBatch_closure" , "-u", "__stginit_Prelude" #endif - ] + +framework-dirs: + #ifdef HAVE_FRAMEWORK_HASKELLSUPPORT - , extra_frameworks = [ "HaskellSupport" ] +extra-frameworks: "HaskellSupport" +#else +extra-frameworks: #endif -} + +haddock-interfaces: +haddock-html: + diff --git a/ghc/utils/ghc-pkg/Main.hs b/ghc/utils/ghc-pkg/Main.hs index b83dd8eb3c..5be72dcb84 100644 --- a/ghc/utils/ghc-pkg/Main.hs +++ b/ghc/utils/ghc-pkg/Main.hs @@ -19,8 +19,8 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) import Distribution.InstalledPackageInfo import Distribution.Compat.ReadP +import Distribution.ParseUtils ( showError ) import Distribution.Package -import Distribution.License import Distribution.Version import Compat.Directory ( getAppUserDataDirectory ) import Control.Exception ( evaluate ) @@ -28,8 +28,6 @@ import qualified Control.Exception as Exception import Prelude -import Package -- the old package config type - #if __GLASGOW_HASKELL__ < 603 #include "config.h" #endif @@ -47,15 +45,13 @@ import qualified Exception import Data.Char ( isSpace ) import Monad import Directory -import System ( getEnv, getArgs, getProgName, +import System ( getArgs, getProgName, system, exitWith, ExitCode(..) ) import IO import List ( isPrefixOf, isSuffixOf ) -import ParsePkgConfLite - #include "../../includes/ghcconfig.h" #ifdef mingw32_HOST_OS @@ -319,14 +315,14 @@ registerPackage input defines db_stack auto_ghci_libs update force = do putStr "Reading package info from stdin... " getContents f -> do - putStr ("Reading package info from " ++ show f) + putStr ("Reading package info from " ++ show f ++ " ") readFile f pkg <- parsePackageInfo s defines force putStrLn "done." validatePackageConfig pkg db_stack auto_ghci_libs update force - new_details <- updatePackageDB (snd db_to_operate_on) pkg + new_details <- updatePackageDB db_stack (snd db_to_operate_on) pkg savePackageConfig db_filename maybeRestoreOldConfig db_filename $ writeNewConfig db_filename new_details @@ -339,67 +335,11 @@ parsePackageInfo parsePackageInfo str defines force = case parseInstalledPackageInfo str of Right ok -> return ok - Left err -> do - old_pkg <- evaluate (parseOnePackageConfig str) - `Exception.catch` \_ -> parse_failed - putStr "Expanding embedded variables... " - new_old_pkg <- expandEnvVars old_pkg defines force - return (convertOldPackage old_pkg) - where - parse_failed = die "parse error in package info\n" - -convertOldPackage :: PackageConfig -> InstalledPackageInfo -convertOldPackage - Package { - name = name, - auto = auto, - import_dirs = import_dirs, - source_dirs = source_dirs, - library_dirs = library_dirs, - hs_libraries = hs_libraries, - extra_libraries = extra_libraries, - include_dirs = include_dirs, - c_includes = c_includes, - package_deps = package_deps, - extra_ghc_opts = extra_ghc_opts, - extra_cc_opts = extra_cc_opts, - extra_ld_opts = extra_ld_opts, - framework_dirs = framework_dirs, - extra_frameworks= extra_frameworks - } - = InstalledPackageInfo { - package = pkgNameToId name, - license = AllRightsReserved, - copyright = "", - maintainer = "", - author = "", - stability = "", - homepage = "", - pkgUrl = "", - description = "", - category = "", - exposed = auto, - exposedModules = [], - hiddenModules = [], - importDirs = import_dirs, - libraryDirs = library_dirs, - hsLibraries = hs_libraries, - extraLibraries = extra_libraries, - includeDirs = include_dirs, - includes = c_includes, - depends = map pkgNameToId package_deps, - extraHugsOpts = [], - extraCcOpts = extra_cc_opts, - extraLdOpts = extra_ld_opts, - frameworkDirs = framework_dirs, - extraFrameworks = extra_frameworks, - haddockInterfaces = [], - haddockHTMLs = [] - } - - --- Used for converting old versionless package names to new PackageIdentifiers. --- "Version [] []" is special: it means "no version" or "any version" + Left err -> die (showError err ++ "\n") + +-- Used for converting versionless package names to new +-- PackageIdentifiers. "Version [] []" is special: it means "no +-- version" or "any version" pkgNameToId :: String -> PackageIdentifier pkgNameToId name = PackageIdentifier name (Version [] []) @@ -603,12 +543,15 @@ checkDep db_stack force pkgid where -- for backwards compat, we treat 0.0 as a special version, -- and don't check that it actually exists. - real_version = versionBranch (pkgVersion pkgid) /= [] + real_version = realVersion pkgid all_pkgs = concat (map snd db_stack) pkgids = map package all_pkgs pkg_names = map pkgName pkgids +realVersion :: PackageIdentifier -> Bool +realVersion pkgid = versionBranch (pkgVersion pkgid) /= [] + checkHSLib :: [String] -> Bool -> Bool -> String -> IO () checkHSLib dirs auto_ghci_libs force lib = do let batch_lib_file = "lib" ++ lib ++ ".a" @@ -660,11 +603,25 @@ autoBuildGHCiLib dir batch_file ghci_file = do -- Updating the DB with the new package. updatePackageDB - :: [InstalledPackageInfo] + :: PackageDBStack + -> [InstalledPackageInfo] -> InstalledPackageInfo -> IO [InstalledPackageInfo] -updatePackageDB pkgs new_pkg = do +updatePackageDB db_stack pkgs new_pkg = do let + -- we update dependencies without version numbers to + -- match the actual versions of the relevant packages instaled. + updateDeps p = p{depends = map resolveDep (depends p)} + + resolveDep pkgid + | realVersion pkgid = pkgid + | otherwise = lookupDep (pkgName pkgid) + + lookupDep name + = head [ pid | p <- concat (map snd db_stack), + let pid = package p, + pkgName pid == name ] + is_exposed = exposed new_pkg pkgid = package new_pkg name = pkgName pkgid @@ -679,7 +636,45 @@ updatePackageDB pkgs new_pkg = do | is_exposed && pkgName (package p) == name = p{ exposed = False } | otherwise = p -- - return (pkgs'++[new_pkg]) + return (pkgs'++[updateDeps new_pkg]) + +-- ----------------------------------------------------------------------------- +-- Searching for modules + +#if not_yet + +findModules :: [FilePath] -> IO [String] +findModules paths = + mms <- mapM searchDir paths + return (concat mms) + +searchDir path prefix = do + fs <- getDirectoryEntries path `catch` \_ -> return [] + searchEntries path prefix fs + +searchEntries path prefix [] = return [] +searchEntries path prefix (f:fs) + | looks_like_a_module = do + ms <- searchEntries path prefix fs + return (prefix `joinModule` f : ms) + | looks_like_a_component = do + ms <- searchDir (path `joinFilename` f) (prefix `joinModule` f) + ms' <- searchEntries path prefix fs + return (ms ++ ms') + | otherwise + searchEntries path prefix fs + + where + (base,suffix) = splitFileExt f + looks_like_a_module = + suffix `elem` haskell_suffixes && + all okInModuleName base + looks_like_a_component = + null suffix && all okInModuleName base + +okInModuleName c + +#endif -- ----------------------------------------------------------------------------- -- The old command-line syntax, supported for backwards compatibility @@ -776,6 +771,8 @@ oldRunit clis = do -- --------------------------------------------------------------------------- +#ifdef OLD_STUFF +-- ToDo: reinstate expandEnvVars :: PackageConfig -> [(String, String)] -> Bool -> IO PackageConfig expandEnvVars pkg defines force = do @@ -859,6 +856,7 @@ wordsBy :: (Char -> Bool) -> String -> [String] wordsBy p s = case dropWhile p s of "" -> [] s' -> w : wordsBy p s'' where (w,s'') = break p s' +#endif ----------------------------------------------------------------------------- diff --git a/ghc/utils/ghc-pkg/Package.hs b/ghc/utils/ghc-pkg/Package.hs deleted file mode 100644 index c43fd6e4e5..0000000000 --- a/ghc/utils/ghc-pkg/Package.hs +++ /dev/null @@ -1,100 +0,0 @@ ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 2004 --- --- BACKWARDS COMPATIBILITY only. This is the old (pre-6.4) package --- configuration type, which is still accepted by ghc-pkg for --- compatibility. The new type is InstalledPackageInfo from the --- Distribution.InstalledPackageInfo module. --- ------------------------------------------------------------------------------ - -module Package ( - PackageConfig(..), defaultPackageConfig - , listPkgs -- :: [PackageConfig] -> String - , dumpPackages -- :: [PackageConfig] -> String - , dumpPkgGuts -- :: PackageConfig -> Doc - , dumpFieldContents -- :: [String] -> Doc - ) where - -#if __GLASGOW_HASKELL__ >= 504 && !defined(INTERNAL_PRETTY) -import Text.PrettyPrint -#else -import Pretty -#endif - -data PackageConfig - = Package { - name :: String, - auto :: Bool, - import_dirs :: [String], - source_dirs :: [String], - library_dirs :: [String], - hs_libraries :: [String], - extra_libraries :: [String], - include_dirs :: [String], - c_includes :: [String], - package_deps :: [String], - extra_ghc_opts :: [String], - extra_cc_opts :: [String], - extra_ld_opts :: [String], - framework_dirs :: [String], -- ignored everywhere but on Darwin/MacOS X - extra_frameworks:: [String] -- ignored everywhere but on Darwin/MacOS X - } - -defaultPackageConfig - = Package { - name = error "defaultPackage", - auto = False, - import_dirs = [], - source_dirs = [], - library_dirs = [], - hs_libraries = [], - extra_libraries = [], - include_dirs = [], - c_includes = [], - package_deps = [], - extra_ghc_opts = [], - extra_cc_opts = [], - extra_ld_opts = [], - framework_dirs = [], - extra_frameworks= [] - } - ------------------------------------------------------------------------------ --- Pretty printing package info - -listPkgs :: [PackageConfig] -> String -listPkgs pkgs = render (fsep (punctuate comma (map (text . name) pkgs))) - -dumpPackages :: [PackageConfig] -> String -dumpPackages pkgs = - render (brackets (vcat (punctuate comma (map dumpPkgGuts pkgs)))) - -dumpPkgGuts :: PackageConfig -> Doc -dumpPkgGuts pkg = - text "Package" $$ nest 3 (braces ( - sep (punctuate comma [ - text "name = " <> text (show (name pkg)), - text "auto = " <> text (show (auto pkg)), - dumpField "import_dirs" (import_dirs pkg), - dumpField "source_dirs" (source_dirs pkg), - dumpField "library_dirs" (library_dirs pkg), - dumpField "hs_libraries" (hs_libraries pkg), - dumpField "extra_libraries" (extra_libraries pkg), - dumpField "include_dirs" (include_dirs pkg), - dumpField "c_includes" (c_includes pkg), - dumpField "package_deps" (package_deps pkg), - dumpField "extra_ghc_opts" (extra_ghc_opts pkg), - dumpField "extra_cc_opts" (extra_cc_opts pkg), - dumpField "extra_ld_opts" (extra_ld_opts pkg), - dumpField "framework_dirs" (framework_dirs pkg), - dumpField "extra_frameworks"(extra_frameworks pkg) - ]))) - -dumpField :: String -> [String] -> Doc -dumpField name val = hang (text name <+> equals) 2 (dumpFieldContents val) - -dumpFieldContents :: [String] -> Doc -dumpFieldContents val = brackets (sep (punctuate comma (map (text . show) val))) - diff --git a/ghc/utils/ghc-pkg/ParsePkgConfLite.y b/ghc/utils/ghc-pkg/ParsePkgConfLite.y deleted file mode 100644 index d4d8ddbf6a..0000000000 --- a/ghc/utils/ghc-pkg/ParsePkgConfLite.y +++ /dev/null @@ -1,128 +0,0 @@ -{ --- This parser is based on ParsedPkgConf.y in compiler/main/ --- It's supposed to do the same thing, but without depending on other GHC modules. --- The disadvantage is the less sophisticated error reporting, and it's probably --- slower because it doesn't use FastStrings. - -module ParsePkgConfLite{- ( parsePackageConfig, parseOnePackageConfig ) -}where - -import Package ( PackageConfig(..), defaultPackageConfig ) -import Char(isSpace, isAlpha, isAlphaNum, isUpper) -import List(break) -} - -%token - '{' { ITocurly } - '}' { ITccurly } - '[' { ITobrack } - ']' { ITcbrack } - ',' { ITcomma } - '=' { ITequal } - VARID { ITvarid $$ } - CONID { ITconid $$ } - STRING { ITstring $$ } - -%name parse pkgconf -%name parseOne pkg -%tokentype { Token } -%% - -pkgconf :: { [ PackageConfig ] } - : '[' ']' { [] } - | '[' pkgs ']' { reverse $2 } - -pkgs :: { [ PackageConfig ] } - : pkg { [ $1 ] } - | pkgs ',' pkg { $3 : $1 } - -pkg :: { PackageConfig } - : CONID '{' fields '}' { $3 defaultPackageConfig } - -fields :: { PackageConfig -> PackageConfig } - : field { \p -> $1 p } - | fields ',' field { \p -> $1 ($3 p) } - -field :: { PackageConfig -> PackageConfig } - : VARID '=' STRING - {\p -> case $1 of - "name" -> p{name = $3} - _ -> error "unknown key in config file" } - - | VARID '=' bool - {\p -> case $1 of { - "auto" -> p{auto = $3}; - _ -> p } } - - | VARID '=' strlist - {\p -> case $1 of - "import_dirs" -> p{import_dirs = $3} - "library_dirs" -> p{library_dirs = $3} - "hs_libraries" -> p{hs_libraries = $3} - "extra_libraries" -> p{extra_libraries = $3} - "include_dirs" -> p{include_dirs = $3} - "c_includes" -> p{c_includes = $3} - "package_deps" -> p{package_deps = $3} - "extra_ghc_opts" -> p{extra_ghc_opts = $3} - "extra_cc_opts" -> p{extra_cc_opts = $3} - "extra_ld_opts" -> p{extra_ld_opts = $3} - "framework_dirs" -> p{framework_dirs = $3} - "extra_frameworks"-> p{extra_frameworks= $3} - _other -> p - } - -strlist :: { [String] } - : '[' ']' { [] } - | '[' strs ']' { reverse $2 } - -strs :: { [String] } - : STRING { [ $1 ] } - | strs ',' STRING { $3 : $1 } - -bool :: { Bool } - : CONID {% case $1 of { - "True" -> True; - "False" -> False; - _ -> error ("unknown constructor in config file: " ++ $1) } } -{ -data Token = - ITocurly - | ITccurly - | ITobrack - | ITcbrack - | ITcomma - | ITequal - | ITvarid String - | ITconid String - | ITstring String - -lexer :: String -> [Token] - -lexer [] = [] -lexer ('{':cs) = ITocurly : lexer cs -lexer ('}':cs) = ITccurly : lexer cs -lexer ('[':cs) = ITobrack : lexer cs -lexer (']':cs) = ITcbrack : lexer cs -lexer (',':cs) = ITcomma : lexer cs -lexer ('=':cs) = ITequal : lexer cs -lexer ('"':cs) = lexString cs "" -lexer (c:cs) - | isSpace c = lexer cs - | isAlpha c = lexID (c:cs) where -lexer _ = error "Unexpected token" - -lexID cs = (if isUpper (head cs) then ITconid else ITvarid) id : lexer rest - where - (id,rest) = break (\c -> c /= '_' && not (isAlphaNum c)) cs - -lexString ('"':cs) s = ITstring (reverse s) : lexer cs -lexString ('\\':c:cs) s = lexString cs (c:s) -lexString (c:cs) s = lexString cs (c:s) - -happyError _ = error "Couldn't parse package configuration." - -parsePackageConfig :: String -> [PackageConfig] -parsePackageConfig = parse . lexer - -parseOnePackageConfig :: String -> PackageConfig -parseOnePackageConfig = parseOne . lexer -} diff --git a/mk/package.mk b/mk/package.mk index c533050dfb..bff2772058 100644 --- a/mk/package.mk +++ b/mk/package.mk @@ -1,5 +1,5 @@ # ----------------------------------------------------------------------------- -# $Id: package.mk,v 1.41 2004/11/23 12:35:12 ross Exp $ +# $Id: package.mk,v 1.42 2004/11/26 16:22:13 simonmar Exp $ ifneq "$(PACKAGE)" "" @@ -17,20 +17,35 @@ endif ifeq "$(way)" "" ifeq "$(STANDALONE_PACKAGE)" "NO" -PKGCONF_CPP_EXTRA_OPTS = -I$(GHC_INCLUDE_DIR) -Iinclude +PACKAGE_CPP_OPTS += -I$(GHC_INCLUDE_DIR) -Iinclude else -PKGCONF_CPP_EXTRA_OPTS = -Iinclude +PACKAGE_CPP_OPTS += -Iinclude endif +PACKAGE_CPP_OPTS += -DPACKAGE=${PACKAGE} +PACKAGE_CPP_OPTS += -DVERSION=${VERSION} + +IMPORT_DIR_INSTALLED = $$libdir/imports +IMPORT_DIR_INPLACE = $$libdir/libraries/$(PACKAGE) + +LIB_DIR_INSTALLED = $$libdir +LIB_DIR_INPLACE = $$libdir/libraries/$(PACKAGE) + package.conf.inplace : package.conf.in - $(CPP) $(RAWCPP_FLAGS) -P $(PKGCONF_CPP_EXTRA_OPTS) -x c $(PACKAGE_CPP_OPTS) $< | \ + $(CPP) $(RAWCPP_FLAGS) -P \ + -DIMPORT_DIR='"$(IMPORT_DIR_INPLACE)"' \ + -DLIB_DIR='"$(LIB_DIR_INPLACE)"' \ + -x c $(PACKAGE_CPP_OPTS) $< | \ grep -v '^#pragma GCC' | \ - sed -e 's/""//g' -e 's/\[ *,/[ /g' >$@ + sed -e 's/""//g' -e 's/:[ ]*,/: /g' >$@ package.conf.installed : package.conf.in - $(CPP) $(RAWCPP_FLAGS) -P $(PKGCONF_CPP_EXTRA_OPTS) -DINSTALLING -x c $(PACKAGE_CPP_OPTS) $< | \ + $(CPP) $(RAWCPP_FLAGS) -P -DINSTALLING \ + -DIMPORT_DIR='"$(IMPORT_DIR_INSTALLED)"' \ + -DLIB_DIR='"$(LIB_DIR_INSTALLED)"' \ + -x c $(PACKAGE_CPP_OPTS) $< | \ grep -v '^#pragma GCC' | \ - sed -e 's/""//g' -e 's/\[ *,/[ /g' >$@ + sed -e 's/""//g' -e 's/:[ ]*,/: /g' >$@ # we could be more accurate here and add a dependency on # ghc/driver/package.conf, but that doesn't work too well because of @@ -61,7 +76,6 @@ CLEAN_FILES += package.conf.installed package.conf.inplace else # $(STANDALONE_PACKAGE) == "YES" -PACKAGE_CPP_OPTS += -DPACKAGE=\"${PACKAGE}\" PACKAGE_CPP_OPTS += -DPACKAGE_DEPS='$(subst " ","$(comma) ",$(patsubst %,"%",$(PACKAGE_DEPS)))' PACKAGE_CPP_OPTS += -DLIBRARY=\"HS$(PACKAGE)\" PACKAGE_CPP_OPTS += -DLIBDIR=\"$(libdir)\" @@ -92,7 +106,7 @@ endif SRC_HSC2HS_OPTS += -I. ifeq "$(NON_HS_PACKAGE)" "" -SRC_HC_OPTS += -package-name $(PACKAGE) +SRC_HC_OPTS += -ignore-package $(PACKAGE) SRC_HC_OPTS += $(GhcLibHcOpts) SRC_HC_OPTS += $(patsubst %, -package %, $(PACKAGE_DEPS)) endif |