%
% (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, icInScopeTTs, icPlusGblRdrEnv,
extendInteractiveContext, substInteractiveContext,
InteractiveImport(..),
mkPrintUnqualified, pprModulePrefix,
ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache,
emptyIfaceWarnCache,
FixityEnv, FixItem(..), lookupFixity, emptyFixityEnv,
TyThing(..), tyThingAvailInfo,
tyThingTyCon, tyThingDataCon,
tyThingId, tyThingCoAxiom, tyThingParent_maybe, tyThingsTyVars,
implicitTyThings, implicitTyConThings, implicitClassThings,
isImplicitTyThing,
TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
typeEnvFromEntities, mkTypeEnvWithImplicits,
extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
typeEnvElts, typeEnvTyCons, typeEnvIds,
typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
MonadThings(..),
WhetherHasOrphans, IsBootInterface, Usage(..),
Dependencies(..), noDependencies,
NameCache(..), OrigNameCache, OrigIParamCache,
IfaceExport,
Warnings(..), WarningTxt(..), plusWarns,
Linkable(..), isObjectLinkable, linkableObjs,
Unlinked(..), CompiledByteCode,
isObject, nameOfObject, isInterpretable, byteCodeOfObject,
HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,
ModBreaks (..), BreakIndex, emptyModBreaks,
VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
noIfaceVectInfo, isNoIfaceVectInfo,
IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
trustInfoToNum, numToTrustInfo, IsSafeImport,
HsParsedModule(..),
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 Avail
import Module
import InstEnv ( InstEnv, Instance )
import FamInstEnv
import Rules ( RuleBase )
import CoreSyn ( CoreProgram )
import Name
import NameEnv
import NameSet
import VarEnv
import VarSet
import Var
import Id
import IdInfo ( IdDetails(..) )
import Type
import Annotations
import Class
import TyCon
import DataCon
import PrelNames ( gHC_PRIM )
import Packages hiding ( Version(..) )
import DynFlags
import DriverPhases
import BasicTypes
import OptimizationFuel ( OptFuelState )
import IfaceSyn
import CoreSyn ( CoreRule, CoreVect )
import Maybes
import Outputable
import BreakArray
import SrcLoc
import Unique
import UniqFM
import UniqSupply
import FastString
import StringBuffer ( StringBuffer )
import Fingerprint
import MonadUtils
import Bag
import ErrUtils
import Util
import Control.Monad ( mplus, guard, liftM, when )
import Data.Array ( Array, array )
import Data.IORef
import Data.Map ( Map )
import Data.Word
import Data.Typeable ( Typeable )
import Exception
import System.FilePath
import System.Time ( ClockTime )
mkSrcErr :: ErrorMessages -> SourceError
mkSrcErr = SourceError
srcErrorMessages :: SourceError -> ErrorMessages
srcErrorMessages (SourceError msgs) = msgs
mkApiErr :: SDoc -> GhcApiError
mkApiErr = 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
handleSourceError :: (ExceptionMonad m) =>
(SourceError -> m a)
-> m a
-> m a
handleSourceError handler act =
gcatch act (\(e :: SourceError) -> handler e)
newtype GhcApiError = GhcApiError SDoc
deriving Typeable
instance Show GhcApiError where
show (GhcApiError msg) = showSDoc msg
instance Exception 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}
%************************************************************************
%* *
\subsection{HscEnv}
%* *
%************************************************************************
\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
\end{code}
%************************************************************************
%* *
\subsection{Package and Module Tables}
%* *
%************************************************************************
\begin{code}
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
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_flag_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
}
type IfaceExport = AvailInfo
emptyModIface :: Module -> ModIface
emptyModIface mod
= ModIface { mi_module = mod,
mi_iface_hash = fingerprint0,
mi_mod_hash = fingerprint0,
mi_flag_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 }
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_tcs :: ![TyCon],
mg_insts :: ![Instance],
mg_fam_insts :: ![FamInst],
mg_rules :: ![CoreRule],
mg_binds :: !CoreProgram,
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_safe_haskell :: SafeHaskellMode,
mg_trust_pkg :: Bool,
mg_dependent_files :: [FilePath]
}
data CgGuts
= CgGuts {
cg_module :: !Module,
cg_tycons :: [TyCon],
cg_binds :: CoreProgram,
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}
%************************************************************************
%* *
\subsection{The interactive context}
%* *
%************************************************************************
\begin{code}
data InteractiveContext
= InteractiveContext {
ic_imports :: [InteractiveImport],
ic_rn_gbl_env :: GlobalRdrEnv,
ic_tythings :: [TyThing],
ic_sys_vars :: [Id],
ic_instances :: ([Instance], [FamInst]),
#ifdef GHCI
ic_resume :: [Resume],
#endif
ic_cwd :: Maybe FilePath
}
emptyInteractiveContext :: InteractiveContext
emptyInteractiveContext
= InteractiveContext { ic_imports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv,
ic_tythings = [],
ic_sys_vars = [],
ic_instances = ([],[]),
#ifdef GHCI
ic_resume = [],
#endif
ic_cwd = Nothing }
icInScopeTTs :: InteractiveContext -> [TyThing]
icInScopeTTs = ic_tythings
icPrintUnqual :: DynFlags -> InteractiveContext -> PrintUnqualified
icPrintUnqual dflags InteractiveContext{ ic_rn_gbl_env = grenv } =
mkPrintUnqualified dflags grenv
extendInteractiveContext :: InteractiveContext -> [TyThing] -> InteractiveContext
extendInteractiveContext ictxt new_tythings
= ictxt { ic_tythings = new_tythings ++ old_tythings
, ic_rn_gbl_env = new_tythings `icPlusGblRdrEnv` ic_rn_gbl_env ictxt
}
where
old_tythings = filter (not . shadowed) (ic_tythings ictxt)
shadowed (AnId id) = ((`elem` new_names) . nameOccName . idName) id
shadowed _ = False
new_names = [ nameOccName (getName id) | AnId id <- new_tythings ]
icPlusGblRdrEnv :: [TyThing] -> GlobalRdrEnv -> GlobalRdrEnv
icPlusGblRdrEnv tythings env = extendOccEnvList env list
where new_gres = gresFromAvails LocalDef (map tyThingAvailInfo tythings)
list = [ (nameOccName (gre_name gre), [gre]) | gre <- new_gres ]
substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
substInteractiveContext ictxt subst
| isEmptyTvSubst subst = ictxt
substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst
= ictxt { ic_tythings = map subst_ty tts }
where subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id)
subst_ty tt = tt
data InteractiveImport
= IIDecl (ImportDecl RdrName)
| IIModule Module
instance Outputable InteractiveImport where
ppr (IIModule m) = char '*' <> ppr m
ppr (IIDecl d) = ppr d
\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 name
| [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
mod = nameModule name
occ = nameOccName name
is_rdr_orig = nameUnique name == mkUniqueGrimily 0
right_name gre
| is_rdr_orig = nameModule_maybe (gre_name gre) == Just mod
| otherwise = gre_name gre == name
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 (ADataCon dc) = map AnId (dataConImplicitIds dc)
implicitClassThings :: Class -> [TyThing]
implicitClassThings cl
=
map ATyCon (classATs cl) ++
map AnId (classAllSelIds cl)
implicitTyConThings :: TyCon -> [TyThing]
implicitTyConThings tc
= class_stuff ++
implicitCoTyCon tc ++
concatMap (extras_plus . ADataCon) (tyConDataCons tc)
where
class_stuff = case tyConClass_maybe tc of
Nothing -> []
Just cl -> implicitClassThings cl
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 (ATyCon tc) = isImplicitTyCon tc
isImplicitTyThing (ACoAxiom {}) = True
tyThingParent_maybe :: TyThing -> Maybe TyThing
tyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
tyThingParent_maybe (ATyCon tc) = case tyConAssoc_maybe tc of
Just cls -> Just (ATyCon (classTyCon cls))
Nothing -> Nothing
tyThingParent_maybe (AnId id) = case idDetails id of
RecSelId { sel_tycon = tc } -> Just (ATyCon tc)
ClassOpId cls -> Just (ATyCon (classTyCon cls))
_other -> Nothing
tyThingParent_maybe _other = Nothing
tyThingsTyVars :: [TyThing] -> TyVarSet
tyThingsTyVars tts =
unionVarSets $ map ttToVarSet tts
where
ttToVarSet (AnId id) = tyVarsOfType $ idType id
ttToVarSet (ADataCon dc) = tyVarsOfType $ dataConRepType dc
ttToVarSet (ATyCon tc)
= case tyConClass_maybe tc of
Just cls -> (mkVarSet . fst . classTvsFds) cls
Nothing -> tyVarsOfType $ tyConKind tc
ttToVarSet _ = emptyVarSet
tyThingAvailInfo :: TyThing -> AvailInfo
tyThingAvailInfo (ATyCon t)
= case tyConClass_maybe t of
Just c -> AvailTC n (n : map getName (classMethods c)
++ map getName (classATs c))
where n = getName c
Nothing -> AvailTC n (n : map getName dcs ++
concatMap dataConFieldLabels dcs)
where n = getName t
dcs = tyConDataCons t
tyThingAvailInfo t
= Avail (getName t)
\end{code}
%************************************************************************
%* *
TypeEnv
%* *
%************************************************************************
\begin{code}
type TypeEnv = NameEnv TyThing
emptyTypeEnv :: TypeEnv
typeEnvElts :: TypeEnv -> [TyThing]
typeEnvTyCons :: TypeEnv -> [TyCon]
typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
typeEnvIds :: TypeEnv -> [Id]
typeEnvDataCons :: TypeEnv -> [DataCon]
typeEnvClasses :: TypeEnv -> [Class]
lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing
emptyTypeEnv = emptyNameEnv
typeEnvElts env = nameEnvElts 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]
typeEnvClasses env = [cl | tc <- typeEnvTyCons env,
Just cl <- [tyConClass_maybe tc]]
mkTypeEnv :: [TyThing] -> TypeEnv
mkTypeEnv things = extendTypeEnvList emptyTypeEnv things
mkTypeEnvWithImplicits :: [TyThing] -> TypeEnv
mkTypeEnvWithImplicits things =
mkTypeEnv things
`plusNameEnv`
mkTypeEnv (concatMap implicitTyThings things)
typeEnvFromEntities :: [Id] -> [TyCon] -> [FamInst] -> TypeEnv
typeEnvFromEntities ids tcs faminsts =
mkTypeEnv ( map AnId ids
++ map ATyCon all_tcs
++ concatMap implicitTyConThings all_tcs
)
where
all_tcs = tcs ++ map famInstTyCon faminsts
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
extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
extendTypeEnvWithIds env ids
= extendNameEnvList env [(getName id, AnId id) | id <- ids]
\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)
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
\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}
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
}
| UsageFile {
usg_file_path :: FilePath,
usg_mtime :: ClockTime
}
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 FastString (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,
ideclImplicit = True,
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)
, vectInfoScalarVars :: VarSet
, vectInfoScalarTyCons :: NameSet
}
data IfaceVectInfo
= IfaceVectInfo
{ ifaceVectInfoVar :: [Name]
, ifaceVectInfoTyCon :: [Name]
, ifaceVectInfoTyConReuse :: [Name]
, ifaceVectInfoScalarVars :: [Name]
, ifaceVectInfoScalarTyCons :: [Name]
}
noVectInfo :: VectInfo
noVectInfo
= VectInfo emptyVarEnv 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)
(vectInfoScalarVars vi1 `unionVarSet` vectInfoScalarVars vi2)
(vectInfoScalarTyCons vi1 `unionNameSets` vectInfoScalarTyCons vi2)
concatVectInfo :: [VectInfo] -> VectInfo
concatVectInfo = foldr plusVectInfo noVectInfo
noIfaceVectInfo :: IfaceVectInfo
noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
isNoIfaceVectInfo :: IfaceVectInfo -> Bool
isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5)
= null l1 && null l2 && null l3 && null l4 && null l5
instance Outputable VectInfo where
ppr info = vcat
[ ptext (sLit "variables :") <+> ppr (vectInfoVar info)
, ptext (sLit "tycons :") <+> ppr (vectInfoTyCon info)
, ptext (sLit "datacons :") <+> ppr (vectInfoDataCon info)
, ptext (sLit "scalar vars :") <+> ppr (vectInfoScalarVars info)
, ptext (sLit "scalar tycons :") <+> ppr (vectInfoScalarTyCons info)
]
\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_Unsafe -> 1
Sf_Trustworthy -> 2
Sf_Safe -> 3
Sf_SafeInfered -> 4
numToTrustInfo :: Word8 -> IfaceTrustInfo
numToTrustInfo 0 = setSafeMode Sf_None
numToTrustInfo 1 = setSafeMode Sf_Unsafe
numToTrustInfo 2 = setSafeMode Sf_Trustworthy
numToTrustInfo 3 = setSafeMode Sf_Safe
numToTrustInfo 4 = setSafeMode Sf_SafeInfered
numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")"
instance Outputable IfaceTrustInfo where
ppr (TrustInfo Sf_None) = ptext $ sLit "none"
ppr (TrustInfo Sf_Unsafe) = ptext $ sLit "unsafe"
ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy"
ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe"
ppr (TrustInfo Sf_SafeInfered) = ptext $ sLit "safe-infered"
\end{code}
%************************************************************************
%* *
\subsection{Parser result}
%* *
%************************************************************************
\begin{code}
data HsParsedModule = HsParsedModule {
hpm_module :: Located (HsModule RdrName),
hpm_src_files :: [FilePath]
}
\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}