%
% (c) The University of Glasgow, 2006
%
\section[HscTypes]{Types for the per-module compiler}
\begin{code}
module HscTypes (
HscEnv(..), hscEPS,
FinderCache, FindResult(..), ModLocationCache,
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
ModDetails(..), emptyModDetails,
ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC,
ImportedMods, ImportedModsVal,
ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
SourceModified(..),
HscSource(..), isHsBoot, hscSourceString,
HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
hptInstances, hptRules, hptVectInfo,
hptObjs,
ExternalPackageState(..), EpsStats(..), addEpsInStats,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
lookupIfaceByModule, emptyModIface,
PackageInstEnv, PackageRuleBase,
prepareAnnotations,
InteractiveContext(..), emptyInteractiveContext,
icPrintUnqual, extendInteractiveContext,
substInteractiveContext,
mkPrintUnqualified, pprModulePrefix,
ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
emptyIfaceWarnCache,
FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
TyThing(..),
tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom,
implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing,
TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
typeEnvDataCons, typeEnvCoAxioms,
MonadThings(..),
WhetherHasOrphans, IsBootInterface, Usage(..),
Dependencies(..), noDependencies,
NameCache(..), OrigNameCache, OrigIParamCache,
Avails, availsToNameSet, availsToNameEnv, availName, availNames,
AvailInfo(..),
IfaceExport, stableAvailCmp,
Warnings(..), WarningTxt(..), plusWarns,
Linkable(..), isObjectLinkable, linkableObjs,
Unlinked(..), CompiledByteCode,
isObject, nameOfObject, isInterpretable, byteCodeOfObject,
HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,
ModBreaks (..), BreakIndex, emptyModBreaks,
VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
noIfaceVectInfo,
IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
trustInfoToNum, numToTrustInfo, IsSafeImport,
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
throwOneError, handleSourceError,
handleFlagWarnings, printOrThrowWarnings,
) where
#include "HsVersions.h"
#ifdef GHCI
import ByteCodeAsm ( CompiledByteCode )
import InteractiveEval ( Resume )
#endif
import HsSyn
import RdrName
import Name
import NameEnv
import NameSet
import Module
import InstEnv ( InstEnv, Instance )
import FamInstEnv ( FamInstEnv, FamInst )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
import VarEnv
import VarSet
import Var
import Id
import Type
import Annotations
import Class ( Class, classAllSelIds, classATs, classTyCon )
import TyCon
import DataCon ( DataCon, dataConImplicitIds, dataConWrapId )
import PrelNames ( gHC_PRIM )
import Packages hiding ( Version(..) )
import DynFlags
import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase )
import BasicTypes ( IPName, defaultFixity, WarningTxt(..) )
import OptimizationFuel ( OptFuelState )
import IfaceSyn
import CoreSyn ( CoreRule, CoreVect )
import Maybes ( orElse, expectJust, catMaybes )
import Outputable
import BreakArray
import SrcLoc
import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import FastString
import StringBuffer ( StringBuffer )
import Fingerprint
import MonadUtils
import Bag
import ErrUtils
import Util
import System.FilePath
import System.Time ( ClockTime )
import Data.IORef
import Data.Array ( Array, array )
import Data.List
import Data.Map (Map)
import Data.Word
import Control.Monad ( mplus, guard, liftM, when )
import Exception
import Data.Typeable ( Typeable )
mkSrcErr :: ErrorMessages -> SourceError
srcErrorMessages :: SourceError -> ErrorMessages
mkApiErr :: SDoc -> GhcApiError
throwOneError :: MonadIO m => ErrMsg -> m ab
throwOneError err = liftIO $ throwIO $ mkSrcErr $ unitBag err
newtype SourceError = SourceError ErrorMessages
deriving Typeable
instance Show SourceError where
show (SourceError msgs) = unlines . map show . bagToList $ msgs
instance Exception SourceError
mkSrcErr = SourceError
handleSourceError :: (ExceptionMonad m) =>
(SourceError -> m a)
-> m a
-> m a
handleSourceError handler act =
gcatch act (\(e :: SourceError) -> handler e)
srcErrorMessages (SourceError msgs) = msgs
newtype GhcApiError = GhcApiError SDoc
deriving Typeable
instance Show GhcApiError where
show (GhcApiError msg) = showSDoc msg
instance Exception GhcApiError
mkApiErr = GhcApiError
printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printOrThrowWarnings dflags warns
| dopt Opt_WarnIsError dflags
= when (not (isEmptyBag warns)) $ do
throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg
| otherwise
= printBagOfWarnings dflags warns
handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
handleFlagWarnings dflags warns
= when (wopt Opt_WarnDeprecatedFlags dflags) $ do
let bag = listToBag [ mkPlainWarnMsg loc (text warn)
| L loc warn <- warns ]
printOrThrowWarnings dflags bag
\end{code}
\begin{code}
data HscEnv
= HscEnv {
hsc_dflags :: DynFlags,
hsc_targets :: [Target],
hsc_mod_graph :: ModuleGraph,
hsc_IC :: InteractiveContext,
hsc_HPT :: HomePackageTable,
hsc_EPS :: !(IORef ExternalPackageState),
hsc_NC :: !(IORef NameCache),
hsc_FC :: !(IORef FinderCache),
hsc_MLC :: !(IORef ModLocationCache),
hsc_OptFuel :: OptFuelState,
hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
}
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS hsc_env = readIORef (hsc_EPS hsc_env)
data Target = Target
{ targetId :: TargetId
, targetAllowObjCode :: Bool
, targetContents :: Maybe (StringBuffer,ClockTime)
}
data TargetId
= TargetModule ModuleName
| TargetFile FilePath (Maybe Phase)
deriving Eq
pprTarget :: Target -> SDoc
pprTarget (Target id obj _) =
(if obj then char '*' else empty) <> pprTargetId id
instance Outputable Target where
ppr = pprTarget
pprTargetId :: TargetId -> SDoc
pprTargetId (TargetModule m) = ppr m
pprTargetId (TargetFile f _) = text f
instance Outputable TargetId where
ppr = pprTargetId
type HomePackageTable = ModuleNameEnv HomeModInfo
type PackageIfaceTable = ModuleEnv ModIface
emptyHomePackageTable :: HomePackageTable
emptyHomePackageTable = emptyUFM
emptyPackageIfaceTable :: PackageIfaceTable
emptyPackageIfaceTable = emptyModuleEnv
data HomeModInfo
= HomeModInfo {
hm_iface :: !ModIface,
hm_details :: !ModDetails,
hm_linkable :: !(Maybe Linkable)
}
lookupIfaceByModule
:: DynFlags
-> HomePackageTable
-> PackageIfaceTable
-> Module
-> Maybe ModIface
lookupIfaceByModule dflags hpt pit mod
| modulePackageId mod == thisPackage dflags
=
fmap hm_iface (lookupUFM hpt (moduleName mod))
`mplus` lookupModuleEnv pit mod
| otherwise = lookupModuleEnv pit mod
\end{code}
\begin{code}
hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([Instance], [FamInst])
hptInstances hsc_env want_this_module
= let (insts, famInsts) = unzip $ flip hptAllThings hsc_env $ \mod_info -> do
guard (want_this_module (moduleName (mi_module (hm_iface mod_info))))
let details = hm_details mod_info
return (md_insts details, md_fam_insts details)
in (concat insts, concat famInsts)
hptVectInfo :: HscEnv -> VectInfo
hptVectInfo = concatVectInfo . hptAllThings ((: []) . md_vect_info . hm_details)
hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule]
hptRules = hptSomeThingsBelowUs (md_rules . hm_details) False
hptAnns :: HscEnv -> Maybe [(ModuleName, IsBootInterface)] -> [Annotation]
hptAnns hsc_env (Just deps) = hptSomeThingsBelowUs (md_anns . hm_details) False hsc_env deps
hptAnns hsc_env Nothing = hptAllThings (md_anns . hm_details) hsc_env
hptAllThings :: (HomeModInfo -> [a]) -> HscEnv -> [a]
hptAllThings extract hsc_env = concatMap extract (eltsUFM (hsc_HPT hsc_env))
hptSomeThingsBelowUs :: (HomeModInfo -> [a]) -> Bool -> HscEnv -> [(ModuleName, IsBootInterface)] -> [a]
hptSomeThingsBelowUs extract include_hi_boot hsc_env deps
| isOneShot (ghcMode (hsc_dflags hsc_env)) = []
| otherwise
= let
hpt = hsc_HPT hsc_env
in
[ thing
|
(mod, is_boot_mod) <- deps
, include_hi_boot || not is_boot_mod
, mod /= moduleName gHC_PRIM
, let things = case lookupUFM hpt mod of
Just info -> extract info
Nothing -> pprTrace "WARNING in hptSomeThingsBelowUs" msg []
msg = vcat [ptext (sLit "missing module") <+> ppr mod,
ptext (sLit "Probable cause: out-of-date interface files")]
, thing <- things ]
hptObjs :: HomePackageTable -> [FilePath]
hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt))
\end{code}
%************************************************************************
%* *
\subsection{Dealing with Annotations}
%* *
%************************************************************************
\begin{code}
prepareAnnotations :: HscEnv -> Maybe ModGuts -> IO AnnEnv
prepareAnnotations hsc_env mb_guts
= do { eps <- hscEPS hsc_env
; let
mb_this_module_anns = fmap (mkAnnEnv . mg_anns) mb_guts
home_pkg_anns = (mkAnnEnv . hptAnns hsc_env) $ fmap (dep_mods . mg_deps) mb_guts
other_pkg_anns = eps_ann_env eps
ann_env = foldl1' plusAnnEnv $ catMaybes [mb_this_module_anns,
Just home_pkg_anns,
Just other_pkg_anns]
; return ann_env }
\end{code}
%************************************************************************
%* *
\subsection{The Finder cache}
%* *
%************************************************************************
\begin{code}
type FinderCache = ModuleNameEnv FindResult
data FindResult
= Found ModLocation Module
| NoPackage PackageId
| FoundMultiple [PackageId]
| NotFound
{ fr_paths :: [FilePath]
, fr_pkg :: Maybe PackageId
, fr_mods_hidden :: [PackageId]
, fr_pkgs_hidden :: [PackageId]
, fr_suggestions :: [Module]
}
type ModLocationCache = ModuleEnv ModLocation
\end{code}
%************************************************************************
%* *
\subsection{Symbol tables and Module details}
%* *
%************************************************************************
\begin{code}
data ModIface
= ModIface {
mi_module :: !Module,
mi_iface_hash :: !Fingerprint,
mi_mod_hash :: !Fingerprint,
mi_orphan :: !WhetherHasOrphans,
mi_finsts :: !WhetherHasFamInst,
mi_boot :: !IsBootInterface,
mi_deps :: Dependencies,
mi_usages :: [Usage],
mi_exports :: ![IfaceExport],
mi_exp_hash :: !Fingerprint,
mi_used_th :: !Bool,
mi_fixities :: [(OccName,Fixity)],
mi_warns :: Warnings,
mi_anns :: [IfaceAnnotation],
mi_decls :: [(Fingerprint,IfaceDecl)],
mi_globals :: !(Maybe GlobalRdrEnv),
mi_insts :: [IfaceInst],
mi_fam_insts :: [IfaceFamInst],
mi_rules :: [IfaceRule],
mi_orphan_hash :: !Fingerprint,
mi_vect_info :: !IfaceVectInfo,
mi_warn_fn :: Name -> Maybe WarningTxt,
mi_fix_fn :: OccName -> Fixity,
mi_hash_fn :: OccName -> Maybe (OccName, Fingerprint),
mi_hpc :: !AnyHpcUsage,
mi_trust :: !IfaceTrustInfo,
mi_trust_pkg :: !Bool
}
data ModDetails
= ModDetails {
md_exports :: [AvailInfo],
md_types :: !TypeEnv,
md_insts :: ![Instance],
md_fam_insts :: ![FamInst],
md_rules :: ![CoreRule],
md_anns :: ![Annotation],
md_vect_info :: !VectInfo
}
emptyModDetails :: ModDetails
emptyModDetails = ModDetails { md_types = emptyTypeEnv,
md_exports = [],
md_insts = [],
md_rules = [],
md_fam_insts = [],
md_anns = [],
md_vect_info = noVectInfo
}
type ImportedMods = ModuleEnv [ImportedModsVal]
type ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
data ModGuts
= ModGuts {
mg_module :: !Module,
mg_boot :: IsBootInterface,
mg_exports :: ![AvailInfo],
mg_deps :: !Dependencies,
mg_dir_imps :: !ImportedMods,
mg_used_names:: !NameSet,
mg_used_th :: !Bool,
mg_rdr_env :: !GlobalRdrEnv,
mg_fix_env :: !FixityEnv,
mg_types :: !TypeEnv,
mg_insts :: ![Instance],
mg_fam_insts :: ![FamInst],
mg_rules :: ![CoreRule],
mg_binds :: ![CoreBind],
mg_foreign :: !ForeignStubs,
mg_warns :: !Warnings,
mg_anns :: [Annotation],
mg_hpc_info :: !HpcInfo,
mg_modBreaks :: !ModBreaks,
mg_vect_decls:: ![CoreVect],
mg_vect_info :: !VectInfo,
mg_inst_env :: InstEnv,
mg_fam_inst_env :: FamInstEnv,
mg_trust_pkg :: Bool
}
data CgGuts
= CgGuts {
cg_module :: !Module,
cg_tycons :: [TyCon],
cg_binds :: [CoreBind],
cg_foreign :: !ForeignStubs,
cg_dep_pkgs :: ![PackageId],
cg_hpc_info :: !HpcInfo,
cg_modBreaks :: !ModBreaks
}
data ForeignStubs = NoStubs
| ForeignStubs
SDoc
SDoc
appendStubC :: ForeignStubs -> SDoc -> ForeignStubs
appendStubC NoStubs c_code = ForeignStubs empty c_code
appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code)
\end{code}
\begin{code}
emptyModIface :: Module -> ModIface
emptyModIface mod
= ModIface { mi_module = mod,
mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_orphan = False,
mi_finsts = False,
mi_boot = False,
mi_deps = noDependencies,
mi_usages = [],
mi_exports = [],
mi_exp_hash = fingerprint0,
mi_used_th = False,
mi_fixities = [],
mi_warns = NoWarnings,
mi_anns = [],
mi_insts = [],
mi_fam_insts = [],
mi_rules = [],
mi_decls = [],
mi_globals = Nothing,
mi_orphan_hash = fingerprint0,
mi_vect_info = noIfaceVectInfo,
mi_warn_fn = emptyIfaceWarnCache,
mi_fix_fn = emptyIfaceFixCache,
mi_hash_fn = emptyIfaceHashCache,
mi_hpc = False,
mi_trust = noIfaceTrustInfo,
mi_trust_pkg = False
}
\end{code}
%************************************************************************
%* *
\subsection{The interactive context}
%* *
%************************************************************************
\begin{code}
data InteractiveContext
= InteractiveContext {
ic_toplev_scope :: [Module],
ic_imports :: [ImportDecl RdrName],
ic_rn_gbl_env :: GlobalRdrEnv,
ic_tmp_ids :: [Id],
#ifdef GHCI
ic_resume :: [Resume],
#endif
ic_cwd :: Maybe FilePath
}
emptyInteractiveContext :: InteractiveContext
emptyInteractiveContext
= InteractiveContext { ic_toplev_scope = [],
ic_imports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv,
ic_tmp_ids = []
#ifdef GHCI
, ic_resume = []
#endif
, ic_cwd = Nothing
}
icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
icPrintUnqual dflags ictxt = mkPrintUnqualified dflags (ic_rn_gbl_env ictxt)
extendInteractiveContext
:: InteractiveContext
-> [Id]
-> InteractiveContext
extendInteractiveContext ictxt ids
= ictxt { ic_tmp_ids = snub ((ic_tmp_ids ictxt \\ ids) ++ ids)
}
where snub = map head . group . sort
substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt
substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst
= ictxt { ic_tmp_ids = map subst_ty ids }
where
subst_ty id = id `setIdType` substTy subst (idType id)
\end{code}
%************************************************************************
%* *
Building a PrintUnqualified
%* *
%************************************************************************
Note [Printing original names]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Deciding how to print names is pretty tricky. We are given a name
P:M.T, where P is the package name, M is the defining module, and T is
the occurrence name, and we have to decide in which form to display
the name given a GlobalRdrEnv describing the current scope.
Ideally we want to display the name in the form in which it is in
scope. However, the name might not be in scope at all, and that's
where it gets tricky. Here are the cases:
1. T uniquely maps to P:M.T ---> "T" NameUnqual
2. There is an X for which X.T
uniquely maps to P:M.T ---> "X.T" NameQual X
3. There is no binding for "M.T" ---> "M.T" NameNotInScope1
4. Otherwise ---> "P:M.T" NameNotInScope2
(3) and (4) apply when the entity P:M.T is not in the GlobalRdrEnv at
all. In these cases we still want to refer to the name as "M.T", *but*
"M.T" might mean something else in the current scope (e.g. if there's
an "import X as M"), so to avoid confusion we avoid using "M.T" if
there's already a binding for it. Instead we write P:M.T.
There's one further subtlety: in case (3), what if there are two
things around, P1:M.T and P2:M.T? Then we don't want to print both of
them as M.T! However only one of the modules P1:M and P2:M can be
exposed (say P2), so we use M.T for that, and P1:M.T for the other one.
This is handled by the qual_mod component of PrintUnqualified, inside
the (ppr mod) of case (3), in Name.pprModulePrefix
\begin{code}
mkPrintUnqualified :: DynFlags -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified dflags env = (qual_name, qual_mod)
where
qual_name mod occ
| [gre] <- unqual_gres, right_name gre = NameUnqual
| [gre] <- qual_gres = NameQual (get_qual_mod (gre_prov gre))
| null qual_gres =
if null (lookupGRE_RdrName (mkRdrQual (moduleName mod) occ) env)
then NameNotInScope1
else NameNotInScope2
| otherwise = panic "mkPrintUnqualified"
where
right_name gre = nameModule_maybe (gre_name gre) == Just mod
unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env
qual_gres = filter right_name (lookupGlobalRdrEnv env occ)
get_qual_mod LocalDef = moduleName mod
get_qual_mod (Imported is) = ASSERT( not (null is) ) is_as (is_decl (head is))
qual_mod mod
| modulePackageId mod == thisPackage dflags = False
| [pkgconfig] <- [pkg | (pkg,exposed_module) <- lookup,
exposed pkg && exposed_module],
packageConfigId pkgconfig == modulePackageId mod
= False
| otherwise = True
where lookup = lookupModuleInAllPackages dflags (moduleName mod)
\end{code}
%************************************************************************
%* *
TyThing
%* *
%************************************************************************
\begin{code}
implicitTyThings :: TyThing -> [TyThing]
implicitTyThings (AnId _) = []
implicitTyThings (ACoAxiom _cc) = []
implicitTyThings (ATyCon tc) = implicitTyConThings tc
implicitTyThings (AClass cl) = implicitClassThings cl
implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
implicitClassThings :: Class -> [TyThing]
implicitClassThings cl
=
extras_plus (ATyCon (classTyCon cl)) ++
map ATyCon (classATs cl) ++
map AnId (classAllSelIds cl)
implicitTyConThings :: TyCon -> [TyThing]
implicitTyConThings tc
=
implicitCoTyCon tc ++
concatMap (extras_plus . ADataCon) (tyConDataCons tc)
extras_plus :: TyThing -> [TyThing]
extras_plus thing = thing : implicitTyThings thing
implicitCoTyCon :: TyCon -> [TyThing]
implicitCoTyCon tc
= map ACoAxiom . catMaybes $ [
newTyConCo_maybe tc,
tyConFamilyCoercion_maybe tc]
isImplicitTyThing :: TyThing -> Bool
isImplicitTyThing (ADataCon {}) = True
isImplicitTyThing (AnId id) = isImplicitId id
isImplicitTyThing (AClass {}) = False
isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc
isImplicitTyThing (ACoAxiom {}) = True
extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds env ids
= extendNameEnvList env [(getName id, AnId id) | id <- ids]
\end{code}
%************************************************************************
%* *
TypeEnv
%* *
%************************************************************************
\begin{code}
type TypeEnv = NameEnv TyThing
emptyTypeEnv :: TypeEnv
typeEnvElts :: TypeEnv -> [TyThing]
typeEnvClasses :: TypeEnv -> [Class]
typeEnvTyCons :: TypeEnv -> [TyCon]
typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
typeEnvIds :: TypeEnv -> [Id]
typeEnvDataCons :: TypeEnv -> [DataCon]
lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
emptyTypeEnv = emptyNameEnv
typeEnvElts env = nameEnvElts env
typeEnvClasses env = [cl | AClass cl <- typeEnvElts env]
typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env]
typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env]
typeEnvIds env = [id | AnId id <- typeEnvElts env]
typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env]
mkTypeEnv :: [TyThing] -> TypeEnv
mkTypeEnv things = extendTypeEnvList emptyTypeEnv things
lookupTypeEnv = lookupNameEnv
extendTypeEnv :: TypeEnv -> TyThing -> TypeEnv
extendTypeEnv env thing = extendNameEnv env (getName thing) thing
extendTypeEnvList :: TypeEnv -> [TyThing] -> TypeEnv
extendTypeEnvList env things = foldl extendTypeEnv env things
\end{code}
\begin{code}
lookupType :: DynFlags
-> HomePackageTable
-> PackageTypeEnv
-> Name
-> Maybe TyThing
lookupType dflags hpt pte name
| not (isOneShot (ghcMode dflags)) && modulePackageId mod == this_pkg
= do hm <- lookupUFM hpt (moduleName mod)
lookupNameEnv (md_types (hm_details hm)) name
| otherwise
= lookupNameEnv pte name
where mod = ASSERT( isExternalName name ) nameModule name
this_pkg = thisPackage dflags
lookupTypeHscEnv :: HscEnv -> Name -> IO (Maybe TyThing)
lookupTypeHscEnv hsc_env name = do
eps <- readIORef (hsc_EPS hsc_env)
return $! lookupType dflags hpt (eps_PTE eps) name
where
dflags = hsc_dflags hsc_env
hpt = hsc_HPT hsc_env
\end{code}
\begin{code}
tyThingTyCon :: TyThing -> TyCon
tyThingTyCon (ATyCon tc) = tc
tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other)
tyThingCoAxiom :: TyThing -> CoAxiom
tyThingCoAxiom (ACoAxiom ax) = ax
tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other)
tyThingClass :: TyThing -> Class
tyThingClass (AClass cls) = cls
tyThingClass other = pprPanic "tyThingClass" (pprTyThing other)
tyThingDataCon :: TyThing -> DataCon
tyThingDataCon (ADataCon dc) = dc
tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other)
tyThingId :: TyThing -> Id
tyThingId (AnId id) = id
tyThingId (ADataCon dc) = dataConWrapId dc
tyThingId other = pprPanic "tyThingId" (pprTyThing other)
\end{code}
%************************************************************************
%* *
\subsection{MonadThings and friends}
%* *
%************************************************************************
\begin{code}
class Monad m => MonadThings m where
lookupThing :: Name -> m TyThing
lookupId :: Name -> m Id
lookupId = liftM tyThingId . lookupThing
lookupDataCon :: Name -> m DataCon
lookupDataCon = liftM tyThingDataCon . lookupThing
lookupTyCon :: Name -> m TyCon
lookupTyCon = liftM tyThingTyCon . lookupThing
lookupClass :: Name -> m Class
lookupClass = liftM tyThingClass . lookupThing
\end{code}
\begin{code}
mkIfaceHashCache :: [(Fingerprint,IfaceDecl)]
-> (OccName -> Maybe (OccName, Fingerprint))
mkIfaceHashCache pairs
= \occ -> lookupOccEnv env occ
where
env = foldr add_decl emptyOccEnv pairs
add_decl (v,d) env0 = foldr add_imp env1 (ifaceDeclSubBndrs d)
where
decl_name = ifName d
env1 = extendOccEnv env0 decl_name (decl_name, v)
add_imp bndr env = extendOccEnv env bndr (decl_name, v)
emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
emptyIfaceHashCache _occ = Nothing
\end{code}
%************************************************************************
%* *
\subsection{Auxiliary types}
%* *
%************************************************************************
These types are defined here because they are mentioned in ModDetails,
but they are mostly elaborated elsewhere
\begin{code}
data Warnings
= NoWarnings
| WarnAll WarningTxt
| WarnSome [(OccName,WarningTxt)]
deriving( Eq )
mkIfaceWarnCache :: Warnings -> Name -> Maybe WarningTxt
mkIfaceWarnCache NoWarnings = \_ -> Nothing
mkIfaceWarnCache (WarnAll t) = \_ -> Just t
mkIfaceWarnCache (WarnSome pairs) = lookupOccEnv (mkOccEnv pairs) . nameOccName
emptyIfaceWarnCache :: Name -> Maybe WarningTxt
emptyIfaceWarnCache _ = Nothing
plusWarns :: Warnings -> Warnings -> Warnings
plusWarns d NoWarnings = d
plusWarns NoWarnings d = d
plusWarns _ (WarnAll t) = WarnAll t
plusWarns (WarnAll t) _ = WarnAll t
plusWarns (WarnSome v1) (WarnSome v2) = WarnSome (v1 ++ v2)
\end{code}
\begin{code}
type Avails = [AvailInfo]
data AvailInfo = Avail Name
| AvailTC Name
[Name]
deriving( Eq )
type IfaceExport = AvailInfo
availsToNameSet :: [AvailInfo] -> NameSet
availsToNameSet avails = foldr add emptyNameSet avails
where add avail set = addListToNameSet set (availNames avail)
availsToNameEnv :: [AvailInfo] -> NameEnv AvailInfo
availsToNameEnv avails = foldr add emptyNameEnv avails
where add avail env = extendNameEnvList env
(zip (availNames avail) (repeat avail))
availName :: AvailInfo -> Name
availName (Avail n) = n
availName (AvailTC n _) = n
availNames :: AvailInfo -> [Name]
availNames (Avail n) = [n]
availNames (AvailTC _ ns) = ns
instance Outputable AvailInfo where
ppr = pprAvail
pprAvail :: AvailInfo -> SDoc
pprAvail (Avail n) = ppr n
pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns)))
stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering
stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2
stableAvailCmp (Avail {}) (AvailTC {}) = LT
stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp`
(cmpList stableNameCmp ns ms)
stableAvailCmp (AvailTC {}) (Avail {}) = GT
\end{code}
\begin{code}
mkIfaceFixCache :: [(OccName, Fixity)] -> OccName -> Fixity
mkIfaceFixCache pairs
= \n -> lookupOccEnv env n `orElse` defaultFixity
where
env = mkOccEnv pairs
emptyIfaceFixCache :: OccName -> Fixity
emptyIfaceFixCache _ = defaultFixity
type FixityEnv = NameEnv FixItem
data FixItem = FixItem OccName Fixity
instance Outputable FixItem where
ppr (FixItem occ fix) = ppr fix <+> ppr occ
emptyFixityEnv :: FixityEnv
emptyFixityEnv = emptyNameEnv
lookupFixity :: FixityEnv -> Name -> Fixity
lookupFixity env n = case lookupNameEnv env n of
Just (FixItem _ fix) -> fix
Nothing -> defaultFixity
\end{code}
%************************************************************************
%* *
\subsection{WhatsImported}
%* *
%************************************************************************
\begin{code}
type WhetherHasOrphans = Bool
type WhetherHasFamInst = Bool
type IsBootInterface = Bool
data Dependencies
= Deps { dep_mods :: [(ModuleName, IsBootInterface)]
, dep_pkgs :: [(PackageId, Bool)]
, dep_orphs :: [Module]
, dep_finsts :: [Module]
}
deriving( Eq )
noDependencies :: Dependencies
noDependencies = Deps [] [] [] []
data Usage
= UsagePackageModule {
usg_mod :: Module,
usg_mod_hash :: Fingerprint,
usg_safe :: IsSafeImport
}
| UsageHomeModule {
usg_mod_name :: ModuleName,
usg_mod_hash :: Fingerprint,
usg_entities :: [(OccName,Fingerprint)],
usg_exports :: Maybe Fingerprint,
usg_safe :: IsSafeImport
}
deriving( Eq )
\end{code}
%************************************************************************
%* *
The External Package State
%* *
%************************************************************************
\begin{code}
type PackageTypeEnv = TypeEnv
type PackageRuleBase = RuleBase
type PackageInstEnv = InstEnv
type PackageFamInstEnv = FamInstEnv
type PackageVectInfo = VectInfo
type PackageAnnEnv = AnnEnv
data ExternalPackageState
= EPS {
eps_is_boot :: !(ModuleNameEnv (ModuleName, IsBootInterface)),
eps_PIT :: !PackageIfaceTable,
eps_PTE :: !PackageTypeEnv,
eps_inst_env :: !PackageInstEnv,
eps_fam_inst_env :: !PackageFamInstEnv,
eps_rule_base :: !PackageRuleBase,
eps_vect_info :: !PackageVectInfo,
eps_ann_env :: !PackageAnnEnv,
eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv),
eps_stats :: !EpsStats
}
data EpsStats = EpsStats { n_ifaces_in
, n_decls_in, n_decls_out
, n_rules_in, n_rules_out
, n_insts_in, n_insts_out :: !Int }
addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats
addEpsInStats stats n_decls n_insts n_rules
= stats { n_ifaces_in = n_ifaces_in stats + 1
, n_decls_in = n_decls_in stats + n_decls
, n_insts_in = n_insts_in stats + n_insts
, n_rules_in = n_rules_in stats + n_rules }
\end{code}
Names in a NameCache are always stored as a Global, and have the SrcLoc
of their binding locations.
Actually that's not quite right. When we first encounter the original
name, we might not be at its binding site (e.g. we are reading an
interface file); so we give it 'noSrcLoc' then. Later, when we find
its binding site, we fix it up.
\begin{code}
data NameCache
= NameCache { nsUniqs :: UniqSupply,
nsNames :: OrigNameCache,
nsIPs :: OrigIParamCache
}
type OrigNameCache = ModuleEnv (OccEnv Name)
type OrigIParamCache = Map (IPName OccName) (IPName Name)
\end{code}
%************************************************************************
%* *
The module graph and ModSummary type
A ModSummary is a node in the compilation manager's
dependency graph, and it's also passed to hscMain
%* *
%************************************************************************
\begin{code}
type ModuleGraph = [ModSummary]
emptyMG :: ModuleGraph
emptyMG = []
data ModSummary
= ModSummary {
ms_mod :: Module,
ms_hsc_src :: HscSource,
ms_location :: ModLocation,
ms_hs_date :: ClockTime,
ms_obj_date :: Maybe ClockTime,
ms_srcimps :: [Located (ImportDecl RdrName)],
ms_textual_imps :: [Located (ImportDecl RdrName)],
ms_hspp_file :: FilePath,
ms_hspp_opts :: DynFlags,
ms_hspp_buf :: Maybe StringBuffer
}
ms_mod_name :: ModSummary -> ModuleName
ms_mod_name = moduleName . ms_mod
ms_imps :: ModSummary -> [Located (ImportDecl RdrName)]
ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms))
where
mk_additional_import mod_nm = noLoc $ ImportDecl {
ideclName = noLoc mod_nm,
ideclPkgQual = Nothing,
ideclSource = False,
ideclQualified = False,
ideclAs = Nothing,
ideclHiding = Nothing,
ideclSafe = False
}
msHsFilePath, msHiFilePath, msObjFilePath :: ModSummary -> FilePath
msHsFilePath ms = expectJust "msHsFilePath" (ml_hs_file (ms_location ms))
msHiFilePath ms = ml_hi_file (ms_location ms)
msObjFilePath ms = ml_obj_file (ms_location ms)
isBootSummary :: ModSummary -> Bool
isBootSummary ms = isHsBoot (ms_hsc_src ms)
instance Outputable ModSummary where
ppr ms
= sep [text "ModSummary {",
nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),
text "ms_mod =" <+> ppr (ms_mod ms)
<> text (hscSourceString (ms_hsc_src ms)) <> comma,
text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),
text "ms_srcimps =" <+> ppr (ms_srcimps ms)]),
char '}'
]
showModMsg :: HscTarget -> Bool -> ModSummary -> String
showModMsg target recomp mod_summary
= showSDoc $
hsep [text (mod_str ++ replicate (max 0 (16 length mod_str)) ' '),
char '(', text (normalise $ msHsFilePath mod_summary) <> comma,
case target of
HscInterpreted | recomp
-> text "interpreted"
HscNothing -> text "nothing"
_ -> text (normalise $ msObjFilePath mod_summary),
char ')']
where
mod = moduleName (ms_mod mod_summary)
mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary)
\end{code}
%************************************************************************
%* *
\subsection{Recmpilation}
%* *
%************************************************************************
\begin{code}
data SourceModified
= SourceModified
| SourceUnmodified
| SourceUnmodifiedAndStable
\end{code}
%************************************************************************
%* *
\subsection{Hpc Support}
%* *
%************************************************************************
\begin{code}
data HpcInfo
= HpcInfo
{ hpcInfoTickCount :: Int
, hpcInfoHash :: Int
}
| NoHpcInfo
{ hpcUsed :: AnyHpcUsage
}
type AnyHpcUsage = Bool
emptyHpcInfo :: AnyHpcUsage -> HpcInfo
emptyHpcInfo = NoHpcInfo
isHpcUsed :: HpcInfo -> AnyHpcUsage
isHpcUsed (HpcInfo {}) = True
isHpcUsed (NoHpcInfo { hpcUsed = used }) = used
\end{code}
%************************************************************************
%* *
\subsection{Vectorisation Support}
%* *
%************************************************************************
The following information is generated and consumed by the vectorisation
subsystem. It communicates the vectorisation status of declarations from one
module to another.
Why do we need both f and f_v in the ModGuts/ModDetails/EPS version VectInfo
below? We need to know `f' when converting to IfaceVectInfo. However, during
vectorisation, we need to know `f_v', whose `Var' we cannot lookup based
on just the OccName easily in a Core pass.
\begin{code}
data VectInfo
= VectInfo
{ vectInfoVar :: VarEnv (Var , Var )
, vectInfoTyCon :: NameEnv (TyCon , TyCon)
, vectInfoDataCon :: NameEnv (DataCon, DataCon)
, vectInfoPADFun :: NameEnv (TyCon , Var)
, vectInfoIso :: NameEnv (TyCon , Var)
, vectInfoScalarVars :: VarSet
, vectInfoScalarTyCons :: NameSet
}
data IfaceVectInfo
= IfaceVectInfo
{ ifaceVectInfoVar :: [Name]
, ifaceVectInfoTyCon :: [Name]
, ifaceVectInfoTyConReuse :: [Name]
, ifaceVectInfoScalarVars :: [Name]
, ifaceVectInfoScalarTyCons :: [Name]
}
noVectInfo :: VectInfo
noVectInfo
= VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyVarSet
emptyNameSet
plusVectInfo :: VectInfo -> VectInfo -> VectInfo
plusVectInfo vi1 vi2 =
VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2)
(vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2)
(vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2)
(vectInfoPADFun vi1 `plusNameEnv` vectInfoPADFun vi2)
(vectInfoIso vi1 `plusNameEnv` vectInfoIso vi2)
(vectInfoScalarVars vi1 `unionVarSet` vectInfoScalarVars vi2)
(vectInfoScalarTyCons vi1 `unionNameSets` vectInfoScalarTyCons vi2)
concatVectInfo :: [VectInfo] -> VectInfo
concatVectInfo = foldr plusVectInfo noVectInfo
noIfaceVectInfo :: IfaceVectInfo
noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
\end{code}
%************************************************************************
%* *
\subsection{Safe Haskell Support}
%* *
%************************************************************************
This stuff here is related to supporting the Safe Haskell extension,
primarily about storing under what trust type a module has been compiled.
\begin{code}
type IsSafeImport = Bool
newtype IfaceTrustInfo = TrustInfo SafeHaskellMode
getSafeMode :: IfaceTrustInfo -> SafeHaskellMode
getSafeMode (TrustInfo x) = x
setSafeMode :: SafeHaskellMode -> IfaceTrustInfo
setSafeMode = TrustInfo
noIfaceTrustInfo :: IfaceTrustInfo
noIfaceTrustInfo = setSafeMode Sf_None
trustInfoToNum :: IfaceTrustInfo -> Word8
trustInfoToNum it
= case getSafeMode it of
Sf_None -> 0
Sf_SafeImports -> 1
Sf_Trustworthy -> 2
Sf_Safe -> 3
numToTrustInfo :: Word8 -> IfaceTrustInfo
numToTrustInfo 0 = setSafeMode Sf_None
numToTrustInfo 1 = setSafeMode Sf_SafeImports
numToTrustInfo 2 = setSafeMode Sf_Trustworthy
numToTrustInfo 3 = setSafeMode Sf_Safe
numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"
instance Outputable IfaceTrustInfo where
ppr (TrustInfo Sf_None) = ptext $ sLit "none"
ppr (TrustInfo Sf_SafeImports) = ptext $ sLit "safe-imports"
ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy"
ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe"
\end{code}
%************************************************************************
%* *
\subsection{Linkable stuff}
%* *
%************************************************************************
This stuff is in here, rather than (say) in Linker.lhs, because the Linker.lhs
stuff is the *dynamic* linker, and isn't present in a stage-1 compiler
\begin{code}
data Linkable = LM {
linkableTime :: ClockTime,
linkableModule :: Module,
linkableUnlinked :: [Unlinked]
}
isObjectLinkable :: Linkable -> Bool
isObjectLinkable l = not (null unlinked) && all isObject unlinked
where unlinked = linkableUnlinked l
linkableObjs :: Linkable -> [FilePath]
linkableObjs l = [ f | DotO f <- linkableUnlinked l ]
instance Outputable Linkable where
ppr (LM when_made mod unlinkeds)
= (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod)
$$ nest 3 (ppr unlinkeds)
data Unlinked
= DotO FilePath
| DotA FilePath
| DotDLL FilePath
| BCOs CompiledByteCode ModBreaks
#ifndef GHCI
data CompiledByteCode = CompiledByteCodeUndefined
_unused :: CompiledByteCode
_unused = CompiledByteCodeUndefined
#endif
instance Outputable Unlinked where
ppr (DotO path) = text "DotO" <+> text path
ppr (DotA path) = text "DotA" <+> text path
ppr (DotDLL path) = text "DotDLL" <+> text path
#ifdef GHCI
ppr (BCOs bcos _) = text "BCOs" <+> ppr bcos
#else
ppr (BCOs _ _) = text "No byte code"
#endif
isObject :: Unlinked -> Bool
isObject (DotO _) = True
isObject (DotA _) = True
isObject (DotDLL _) = True
isObject _ = False
isInterpretable :: Unlinked -> Bool
isInterpretable = not . isObject
nameOfObject :: Unlinked -> FilePath
nameOfObject (DotO fn) = fn
nameOfObject (DotA fn) = fn
nameOfObject (DotDLL fn) = fn
nameOfObject other = pprPanic "nameOfObject" (ppr other)
byteCodeOfObject :: Unlinked -> CompiledByteCode
byteCodeOfObject (BCOs bc _) = bc
byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
\end{code}
%************************************************************************
%* *
\subsection{Breakpoint Support}
%* *
%************************************************************************
\begin{code}
type BreakIndex = Int
data ModBreaks
= ModBreaks
{ modBreaks_flags :: BreakArray
, modBreaks_locs :: !(Array BreakIndex SrcSpan)
, modBreaks_vars :: !(Array BreakIndex [OccName])
, modBreaks_decls :: !(Array BreakIndex [String])
}
emptyModBreaks :: ModBreaks
emptyModBreaks = ModBreaks
{ modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
, modBreaks_locs = array (0,1) []
, modBreaks_vars = array (0,1) []
, modBreaks_decls = array (0,1) []
}
\end{code}