# 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 \
__interface Module 1 0 where
-__export Module ModuleName ;
-1 data ModuleName ;
+__export Module Module ;
+1 data Module ;
module Module where
-data ModuleName
+data Module
%
-% (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
, lookupWithDefaultModuleEnv, mapModuleEnv, mkModuleEnv, emptyModuleEnv
, moduleEnvElts, unitModuleEnv, isEmptyModuleEnv, foldModuleEnv
, extendModuleEnv_C
- , lookupModuleEnvByName, extendModuleEnvByName, unitModuleEnvByName
, ModuleSet, emptyModuleSet, mkModuleSet, moduleSetElts, extendModuleSet, elemModuleSet
#include "HsVersions.h"
import OccName
import Outputable
-import Packages ( PackageName, basePackage )
-import CmdLineOpts ( opt_InPackage )
import Unique ( Uniquable(..) )
import Maybes ( expectJust )
import UniqFM
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}
%************************************************************************
\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}
%************************************************************************
%* *
\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
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
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
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(..),
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 )
nameUnique :: Name -> Unique
nameOccName :: Name -> OccName
nameModule :: Name -> Module
-nameModuleName :: Name -> ModuleName
nameSrcLoc :: Name -> SrcLoc
nameUnique name = n_uniq name
isInternalName :: Name -> Bool
isExternalName :: Name -> Bool
isSystemName :: Name -> Bool
-isHomePackageName :: Name -> Bool
isWiredInName :: Name -> Bool
isWiredInName (Name {n_sort = WiredIn _ _ _ _}) = True
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
| 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)
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
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
= 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
%************************************************************************
\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
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}
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
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)
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}
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
\begin{code}
data Provenance
= LocalDef -- Defined locally
- ModuleName
+ Module
| Imported -- Imported
[ImportSpec] -- INVARIANT: non-empty
-- 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
mkStaticInfoTableLabel,
mkApEntryLabel,
mkApInfoTableLabel,
+ mkClosureTableLabel,
+
+ mkLocalClosureLabel,
+ mkLocalInfoTableLabel,
+ mkLocalEntryLabel,
+ mkLocalConEntryLabel,
+ mkLocalStaticConEntryLabel,
+ mkLocalConInfoTableLabel,
+ mkLocalStaticInfoTableLabel,
+ mkLocalClosureTableLabel,
mkReturnPtLabel,
mkReturnInfoLabel,
mkBitmapLabel,
mkStringLitLabel,
- mkClosureTblLabel,
-
mkAsmTempLabel,
mkModuleInitLabel,
#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 )
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
| 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
= 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
| 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
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
-- -----------------------------------------------------------------------------
-- 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
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
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
-- 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)
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)
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
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
| 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
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?
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
-- 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
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")
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")
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 <>
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")
)
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(..) )
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
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
-- Bug
cgLookupPanic id
}}}}
- where
- name = idName id
- ext_lbl = CmmLit (CmmLabel (mkClosureLabel name))
+
cgLookupPanic :: Id -> FCode a
cgLookupPanic id
%
% (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 $
%
%********************************************************
%* *
-- 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-}
%
% (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}
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
; 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 []
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}
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
-> [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
\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}
\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
\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
-- 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
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}
%
% (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 $
%
%********************************************************
%* *
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
| 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
; 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:
\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
-- 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
for semi-obvious reasons.
\begin{code}
-mkRhsClosure bndr cc bi srt
+mkRhsClosure dflags bndr cc bi srt
fvs
upd_flag
[] -- No args; a thunk
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}
%
% (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}
import CostCentre ( CostCentreStack )
import Util ( mapAccumL, filterOut )
import Constants ( wORD_SIZE )
+import CmdLineOpts ( DynFlags )
import Outputable
import GLAEXTS
\begin{code}
layOutDynConstr, layOutStaticConstr
- :: DataCon
+ :: DynFlags
+ -> DataCon
-> [(CgRep,a)]
-> (ClosureInfo,
[(a,VirtualHpOffset)])
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
%
% (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}
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,
import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds )
+import CmdLineOpts ( DynFlags )
import Cmm
import CmmUtils ( CmmStmts, isNopStmt )
import CLabel
import FastString
import Outputable
+import Control.Monad ( liftM )
+
infixr 9 `thenC` -- Right-associative!
infixr 9 `thenFC`
\end{code}
\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
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,
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
}
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
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}
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 )
-> 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,
%
% (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 $
%
%********************************************************
%* *
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
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 )
--
-------------------------------------------------------------------------
-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)
-------------------------------------------------------------------------
--
closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
closureFunInfo, isStandardFormThunk, isKnownFun,
- enterIdLabel, enterReturnPtLabel,
+ enterIdLabel, enterLocalIdLabel, enterReturnPtLabel,
nodeMustPointToIt,
CallMethod(..), getCallMethod,
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 )
-- 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...
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}
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]
| 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)
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
| 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
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 )
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
-- 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
\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
; 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
-- 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
where
mk_export_register bndr
= emitRtsCall SLIT("getStablePtr")
- [ (CmmLit (CmmLabel (mkClosureLabel (idName bndr))), PtrHint) ]
+ [ (CmmLit (CmmLabel (mkLocalClosureLabel (idName bndr))),
+ PtrHint) ]
\end{code}
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
cmGetModInfo, -- :: CmState -> (ModuleGraph, HomePackageTable)
cmSetDFlags,
+ cmGetDFlags,
+
cmGetBindings, -- :: CmState -> [TyThing]
cmGetPrintUnqual, -- :: CmState -> PrintUnqualified
#endif
#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 )
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 )
#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
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
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
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))
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
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
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)
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
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
-- 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) $
= 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.
-- 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"
-- 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)
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
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
-- 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)
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
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
-- 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)
-- * 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
-- 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
-- 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
-- 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])
-- 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 ......
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
upsweep_mod :: HscEnv
-> UnlinkedImage
-> ModSummary
- -> [ModuleName]
+ -> [Module]
-> IO (SuccessFlag,
HscEnv) -- With updated HPT
= 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
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
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
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"
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
-- 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
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
[ 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
[ (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
-- 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,
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)
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))
= 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
}
]
ms_allimps ms = ms_srcimps ms ++ ms_imps ms
-
-modSummaryName :: ModSummary -> ModuleName
-modSummaryName = moduleName . ms_mod
\end{code}
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,
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.
-- 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
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)
#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,
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
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 )
; 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
; 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,
-- 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,
import Maybe ( catMaybes )
import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) )
import BasicTypes ( isBoxed )
-import Packages ( thPackage )
import Outputable
import Bag ( bagToList )
import FastString ( unpackFS )
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)
{-# 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
--
#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
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 )
" (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;
| 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 []
(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 ()
setGHCiState state{ cmstate = cmstate2, targets = files }
setContextAfterLoad mods
- dflags <- io (getDynFlags)
+ dflags <- getDynFlags
modulesLoadedMsg ok mods dflags
<- io (cmLoadModules (cmstate state) graph)
setGHCiState state{ cmstate=cmstate1 }
setContextAfterLoad mods
- dflags <- io getDynFlags
+ dflags <- getDynFlags
modulesLoadedMsg ok mods dflags
reloadModule _ = noArgs ":reload"
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 ()
state <- getGHCiState
cmstate1 <- io (cmUnload (cmstate state))
setGHCiState state{ cmstate = cmstate1, targets = [] }
- dflags <- io getDynFlags
+ dflags <- getDynFlags
io (linkPackages dflags new_pkgs)
setContextAfterLoad []
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
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(..) )
-- 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}
-- (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}
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
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
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 {
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
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
-- 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}
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
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}
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',
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
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
| 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 ()
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
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
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}
#include "HsVersions.h"
-import Module ( ModuleName )
+import Module ( Module )
import Outputable
import FastString
import SrcLoc ( Located(..) )
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}
| 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}
import VarEnv
import Class ( DefMeth(..) )
import CostCentre
-import Module ( moduleName, mkModule )
import DriverState ( v_Build_tag )
import CmdLineOpts ( opt_HiVersion )
import Kind ( Kind(..) )
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,
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
"mismatched interface file ways: expected "
++ build_tag ++ ", found " ++ check_way))
- pkg_name <- get bh
mod_name <- get bh
mod_vers <- get bh
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,
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 )
-> 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.
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
-- 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)
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 }
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)
| 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
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 )
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;
| 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)))
-- 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}
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
\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
-- 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}
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
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 )
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
%************************************************************************
\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
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 $
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
%*********************************************************
\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
; 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
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
} -- 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 }
-- 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
-- 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})
-----------------------------------------------------
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})
%*********************************************************
\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)
-- 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]")
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)
; 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.
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 ;
};
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
| 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
}}
}
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}
\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
= 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
, 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 =
#include "HsVersions.h"
import HsSyn
+import Packages ( isHomeModule )
import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..),
eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool,
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,
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,
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 )
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
; 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,
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)
-----------------------------
\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
-- (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.
\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
(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
-- 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:"
}
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
-- 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)
, 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
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 )
; 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,
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
}
-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.
-- 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) )
HscLang(..),
DynFlag(..), -- needed non-abstractly by DriverFlags
DynFlags(..),
+ PackageFlag(..),
v_Static_hsc_opts,
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,
-- misc opts
opt_ErrorSpans,
- opt_InPackage,
opt_EmitCExternDecls,
opt_EnsureSplittableC,
opt_GranMacros,
#include "HsVersions.h"
+import {-# SOURCE #-} Packages (PackageState)
import Constants -- Default values for some flags
import Util
import FastString ( FastString, mkFastString )
import Panic ( ghcError, GhcException(UsageError) )
import GLAEXTS
-import DATA_IOREF ( IORef, readIORef, writeIORef )
+import DATA_IOREF ( IORef, readIORef )
import UNSAFE_IO ( unsafePerformIO )
\end{code}
ppFlag :: Bool, -- preprocess with a Haskell Pp?
stolen_x86_regs :: Int,
cmdlineHcIncludes :: [String], -- -#includes
+ importPaths :: [FilePath],
-- options for particular phases
opt_L :: [String],
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
ppFlag = False,
stolen_x86_regs = 4,
cmdlineHcIncludes = [],
+ importPaths = ["."],
opt_L = [],
opt_P = [],
opt_F = [],
opt_I = [],
opt_i = [],
#endif
+
+ extraPkgConfs = [],
+ readUserPkgConf = True,
+ packageFlags = [],
+ pkgState = error "pkgState",
+
flags = [
Opt_Generics,
-- Generating the helper-functions for
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 }
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}
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
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
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")
import PprC ( writeCs )
import CmmLint ( cmmLint )
import Packages
-import DriverState ( getExplicitPackagesAnd, getPackageCIncludes )
import DriverUtil ( filenameOf )
import FastString ( unpackFS )
import Cmm ( Cmm )
-- * 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
"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
-----------------------------------------------------------------------------
module DriverFlags (
- processArgs, OptKind(..), static_flags, dynamic_flags,
+ processDynamicFlags,
+ processStaticFlags,
+
addCmdlineHCInclude,
buildStaticHscOpts,
- machdepCCOpts
+ machdepCCOpts,
+
+ processArgs, OptKind(..), -- for DriverMkDepend only
) where
#include "HsVersions.h"
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
-----------------------------------------------------------------------------
-- 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)
) )
------- Include/Import Paths ----------------------------------------
- , ( "i" , OptPrefix (addToOrDeleteDirList v_Import_paths) )
, ( "I" , Prefix (addToDirList v_Include_paths) )
------- Libraries ---------------------------------------------------
, ( "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 )
, ( "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) )
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
-- , registerised HC compilations
-- )
-machdepCCOpts
+machdepCCOpts dflags
| prefixMatch "alpha" cTARGETPLATFORM
= return ( ["-w", "-mieee"
#ifdef HAVE_THREADED_RTS_SUPPORT
--
-- -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 ""
-----------------------------------------------------------------------------
-- 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
-----------------------------------------------------------------------------
--- $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
--
#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
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"
-- 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
-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
-- 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
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 ""))
-- 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
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.
_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))
| 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
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")
-- ---------------------------------------------------------------------------
-- 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
-> 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
-- 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
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
" 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
-- 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
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
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
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
-- 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
-- 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" ]
| 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
++ 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 []
| 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
]
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
-- 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
, 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
(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
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",
-- 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",
-----------------------------------------------------------------------------
-- 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)))
)))
-----------------------------------------------------------------------------
-- 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 []
-- 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
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
-- 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
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
]
-----------------------------------------------------------------------------
-- 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
-- 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
-- -----------------------------------------------------------------------------
-- 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",
#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
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])
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
\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
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
-- 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
| 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
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.
-- 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,
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
--
-- Parameters are:
--
--- mod_name
+-- mod
-- The name of the module
--
-- path
-- (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
-- 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
-----------------------------------------------------------------------------
--- $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
--
-- 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
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.
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` "'._"
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,
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,
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,
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}
\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
-- 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 {
\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,
-- [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}
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
-- 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
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
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
\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]
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]
}
{-# 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
--
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
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
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
-- 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
{-
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
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
-- -----------------------------------------------------------------------------
-- -----------------------------------------------------------------------------
-- 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"))
| 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
-- ---------------------------------------------------------------------------
-- 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
# 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)
\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}
#include "HsVersions.h"
-import Packages
+import PackageConfig
import Lexer
import CmdLineOpts
import FastString
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 )
\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.
_ -> 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
-- 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?)
-----------------------------------------------------------------------------
-- 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 ->
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
#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), dopt )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding )
import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
-- 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
--
-- * 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
-- 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
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
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
: 'qualified' { True }
| {- empty -} { False }
-maybeas :: { Located (Maybe ModuleName) }
+maybeas :: { Located (Maybe Module) }
: 'as' modid { LL (Just (unLoc $2)) }
| {- empty -} { noLoc Nothing }
-----------------------------------------------------------------------------
-- 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))
}
import RdrName
import OccName
import Kind( Kind(..) )
-import Name( nameOccName, nameModuleName )
+import Name( nameOccName, nameModule )
import Module
import ParserCoreUtils
import LexCore
%%
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
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
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,
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
\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,
#include "HsVersions.h"
-import Module ( Module, mkBasePkgModule, mkHomeModule, mkModuleName )
+import Module ( Module, mkModule )
import OccName ( dataName, tcName, clsName, varName, mkOccFS
)
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}
--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}
%************************************************************************
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
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
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
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
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)
import Name ( UserFS, EncodedFS, encodeFS, decode,
getOccName, occNameFS
)
-import Module ( Module, ModuleName, moduleName )
+import Module ( Module )
import Outputable
import FastTypes
import FastString
| 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
\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 }
| 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}
import StgSyn
-import CmdLineOpts ( opt_AutoSccsOnIndividualCafs )
+import CmdLineOpts ( DynFlags, opt_AutoSccsOnIndividualCafs )
import CostCentre -- lots of things
import Id ( Id )
import Module ( Module )
\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)
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
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,
-- 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
-- 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}
%*********************************************************
-- 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
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
%************************************************************************
\begin{code}
-warnUnusedModules :: [(ModuleName,SrcSpan)] -> RnM ()
+warnUnusedModules :: [(Module,SrcSpan)] -> RnM ()
warnUnusedModules mods
= ifOptM Opt_WarnUnusedImports (mappM_ bleat mods)
where
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,
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(..),
-- 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
= []
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" -}
-- 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 ->
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
filterImports iface imp_spec
imp_details total_avails `thenM` \ (avail_env, gbl_env) ->
+ getDOpts `thenM` \ dflags ->
+
let
-- Compute new transitive dependencies
| 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
-- 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,
; 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
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]
\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)
returnM acc }
| otherwise
- = case lookupModuleEnvByName mod_avail_env mod of
+ = case lookupModuleEnv mod_avail_env mod of
Nothing -> addErr (modExportErr mod) `thenM_`
returnM acc
(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
-- 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
| 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
-- 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
---------------------
-- 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 {
(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")
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}
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
_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
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
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')
)
-- 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
(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')
\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
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 )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
import Unique ( Unique )
import Bitmap
-import CmdLineOpts ( opt_SccProfilingOn )
+import CmdLineOpts ( DynFlags, opt_SccProfilingOn )
\end{code}
%************************************************************************
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
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 )
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
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 = ""
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}
%************************************************************************
#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 )
import TcSimplify ( tcSimplifyTop )
import TcTyClsDecls ( tcTyAndClassDecls )
import LoadIface ( loadOrphanModules, loadHiBootInterface )
-import IfaceEnv ( lookupOrig )
import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
reportUnusedNames, reportDeprecations )
import RnEnv ( lookupSrcOcc_maybe )
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
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,
= 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
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}
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 } } ;
--
--
-- Blimey: a whole page of code to do this...
- | mod_name /= main_mod
+ | mod /= main_mod
= return tcg_env
| otherwise
})
}}}
where
- mod_name = moduleName (tcg_mod tcg_env)
+ mod = tcg_mod tcg_env
complain_no_main | ghci_mode == Interactive = return ()
| otherwise = failWithTc noMainMsg
\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 $
-- 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))
| 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
getModuleContents
:: HscEnv
-> InteractiveContext
- -> ModuleName -- Module to inspect
+ -> Module -- Module to inspect
-> Bool -- Grab just the exports, or the whole toplev
-> IO (Maybe [IfaceDecl])
| 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 $
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)
- \begin{code}
+\begin{code}
module TcRnMonad(
module TcRnMonad,
module TcRnTypes,
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 )
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 )
; 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 }
}
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 }
}
; 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,
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 )
-- 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
-- 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,
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 )
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
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(..) )
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}
#include "HsVersions.h"
-import {-# SOURCE #-} Module( ModuleName )
+import {-# SOURCE #-} Module( Module )
import {-# SOURCE #-} OccName( OccName )
import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
| 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
# 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
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
+/* 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
,"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"
, "-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:
+
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 )
import Prelude
-import Package -- the old package config type
-
#if __GLASGOW_HASKELL__ < 603
#include "config.h"
#endif
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
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
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 [] [])
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"
-- 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
| 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
-- ---------------------------------------------------------------------------
+#ifdef OLD_STUFF
+-- ToDo: reinstate
expandEnvVars :: PackageConfig -> [(String, String)]
-> Bool -> IO PackageConfig
expandEnvVars pkg defines force = do
wordsBy p s = case dropWhile p s of
"" -> []
s' -> w : wordsBy p s'' where (w,s'') = break p s'
+#endif
-----------------------------------------------------------------------------
+++ /dev/null
------------------------------------------------------------------------------
---
--- (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)))
-
+++ /dev/null
-{
--- 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
-}
# -----------------------------------------------------------------------------
-# $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)" ""
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
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)\"
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
projects / ghc-hetmet.git / commitdiff