%
% (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,
HscStatus(..),
Hsc(..), runHsc, runInteractiveHsc,
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, pprHPT,
hptObjs,
ExternalPackageState(..), EpsStats(..), addEpsInStats,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
lookupIfaceByModule, emptyModIface,
PackageInstEnv, PackageFamInstEnv, PackageRuleBase,
mkSOName, mkHsSOName, soExt,
prepareAnnotations,
InteractiveContext(..), emptyInteractiveContext,
icPrintUnqual, icInScopeTTs, icExtendGblRdrEnv,
extendInteractiveContext, substInteractiveContext,
setInteractivePrintName, icInteractiveModule,
InteractiveImport(..), setInteractivePackage,
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, typeEnvPatSyns,
typeEnvDataCons, typeEnvCoAxioms, typeEnvClasses,
MonadThings(..),
WhetherHasOrphans, IsBootInterface, Usage(..),
Dependencies(..), noDependencies,
NameCache(..), OrigNameCache,
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 InteractiveEvalTypes ( Resume )
#endif
import HsSyn
import RdrName
import Avail
import Module
import InstEnv ( InstEnv, ClsInst )
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 ( Annotation, AnnEnv, mkAnnEnv, plusAnnEnv )
import Class
import TyCon
import CoAxiom
import ConLike
import DataCon
import PatSyn
import PrelNames ( gHC_PRIM, ioTyConName, printName, mkInteractiveModule )
import Packages hiding ( Version(..) )
import DynFlags
import DriverPhases ( Phase, HscSource(..), isHsBoot, hscSourceString )
import BasicTypes
import IfaceSyn
import CoreSyn ( CoreRule, CoreVect )
import Maybes
import Outputable
import BreakArray
import SrcLoc
import UniqFM
import UniqSupply
import FastString
import StringBuffer ( StringBuffer )
import Fingerprint
import MonadUtils
import Bag
import Binary
import ErrUtils
import Platform
import Util
import Control.Monad ( guard, liftM, when, ap )
import Data.Array ( Array, array )
import Data.IORef
import Data.Time
import Data.Word
import Data.Typeable ( Typeable )
import Exception
import System.FilePath
data HscStatus
= HscNotGeneratingCode
| HscUpToDate
| HscUpdateBoot
| HscRecomp CgGuts ModSummary
newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages))
instance Functor Hsc where
fmap = liftM
instance Applicative Hsc where
pure = return
(<*>) = ap
instance Monad Hsc where
return a = Hsc $ \_ w -> return (a, w)
Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w
case k a of
Hsc k' -> k' e w1
instance MonadIO Hsc where
liftIO io = Hsc $ \_ w -> do a <- io; return (a, w)
instance HasDynFlags Hsc where
getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w)
runHsc :: HscEnv -> Hsc a -> IO a
runHsc hsc_env (Hsc hsc) = do
(a, w) <- hsc hsc_env emptyBag
printOrThrowWarnings (hsc_dflags hsc_env) w
return a
runInteractiveHsc :: HscEnv -> Hsc a -> IO a
runInteractiveHsc hsc_env
= runHsc (hsc_env { hsc_dflags = interactive_dflags })
where
interactive_dflags = ic_dflags (hsc_IC hsc_env)
mkSrcErr :: ErrorMessages -> SourceError
mkSrcErr = SourceError
srcErrorMessages :: SourceError -> ErrorMessages
srcErrorMessages (SourceError msgs) = msgs
mkApiErr :: DynFlags -> SDoc -> GhcApiError
mkApiErr dflags msg = GhcApiError (showSDoc dflags msg)
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 String
deriving Typeable
instance Show GhcApiError where
show (GhcApiError msg) = msg
instance Exception GhcApiError
printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printOrThrowWarnings dflags warns
| gopt Opt_WarnIsError dflags
= when (not (isEmptyBag warns)) $ do
throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags
| otherwise
= printBagOfErrors dflags warns
handleFlagWarnings :: DynFlags -> [Located String] -> IO ()
handleFlagWarnings dflags warns
= when (wopt Opt_WarnDeprecatedFlags dflags) $ do
let bag = listToBag [ mkPlainWarnMsg dflags 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_type_env_var :: Maybe (Module, IORef TypeEnv)
}
instance ContainsDynFlags HscEnv where
extractDynFlags env = hsc_dflags env
replaceDynFlags env dflags = env {hsc_dflags = dflags}
hscEPS :: HscEnv -> IO ExternalPackageState
hscEPS hsc_env = readIORef (hsc_EPS hsc_env)
data Target
= Target {
targetId :: TargetId,
targetAllowObjCode :: Bool,
targetContents :: Maybe (StringBuffer,UTCTime)
}
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
pprHPT :: HomePackageTable -> SDoc
pprHPT hpt
= vcat [ hang (ppr (mi_module (hm_iface hm)))
2 (ppr (md_types (hm_details hm)))
| hm <- eltsUFM hpt ]
lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo
lookupHptByModule hpt mod
= case lookupUFM hpt (moduleName mod) of
Just hm | mi_module (hm_iface hm) == mod -> Just hm
_otherwise -> Nothing
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
= case lookupHptByModule hpt mod of
Just hm -> Just (hm_iface hm)
Nothing -> lookupModuleEnv pit mod
hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([ClsInst], [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 :: [IfaceClsInst],
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
}
instance Binary ModIface where
put_ bh (ModIface {
mi_module = mod,
mi_boot = is_boot,
mi_iface_hash= iface_hash,
mi_mod_hash = mod_hash,
mi_flag_hash = flag_hash,
mi_orphan = orphan,
mi_finsts = hasFamInsts,
mi_deps = deps,
mi_usages = usages,
mi_exports = exports,
mi_exp_hash = exp_hash,
mi_used_th = used_th,
mi_fixities = fixities,
mi_warns = warns,
mi_anns = anns,
mi_decls = decls,
mi_insts = insts,
mi_fam_insts = fam_insts,
mi_rules = rules,
mi_orphan_hash = orphan_hash,
mi_vect_info = vect_info,
mi_hpc = hpc_info,
mi_trust = trust,
mi_trust_pkg = trust_pkg }) = do
put_ bh mod
put_ bh is_boot
put_ bh iface_hash
put_ bh mod_hash
put_ bh flag_hash
put_ bh orphan
put_ bh hasFamInsts
lazyPut bh deps
lazyPut bh usages
put_ bh exports
put_ bh exp_hash
put_ bh used_th
put_ bh fixities
lazyPut bh warns
lazyPut bh anns
put_ bh decls
put_ bh insts
put_ bh fam_insts
lazyPut bh rules
put_ bh orphan_hash
put_ bh vect_info
put_ bh hpc_info
put_ bh trust
put_ bh trust_pkg
get bh = do
mod_name <- get bh
is_boot <- get bh
iface_hash <- get bh
mod_hash <- get bh
flag_hash <- get bh
orphan <- get bh
hasFamInsts <- get bh
deps <- lazyGet bh
usages <- lazyGet bh
exports <- get bh
exp_hash <- get bh
used_th <- get bh
fixities <- get bh
warns <- lazyGet bh
anns <- lazyGet bh
decls <- get bh
insts <- get bh
fam_insts <- get bh
rules <- lazyGet bh
orphan_hash <- get bh
vect_info <- get bh
hpc_info <- get bh
trust <- get bh
trust_pkg <- get bh
return (ModIface {
mi_module = mod_name,
mi_boot = is_boot,
mi_iface_hash = iface_hash,
mi_mod_hash = mod_hash,
mi_flag_hash = flag_hash,
mi_orphan = orphan,
mi_finsts = hasFamInsts,
mi_deps = deps,
mi_usages = usages,
mi_exports = exports,
mi_exp_hash = exp_hash,
mi_used_th = used_th,
mi_anns = anns,
mi_fixities = fixities,
mi_warns = warns,
mi_decls = decls,
mi_globals = Nothing,
mi_insts = insts,
mi_fam_insts = fam_insts,
mi_rules = rules,
mi_orphan_hash = orphan_hash,
mi_vect_info = vect_info,
mi_hpc = hpc_info,
mi_trust = trust,
mi_trust_pkg = trust_pkg,
mi_warn_fn = mkIfaceWarnCache warns,
mi_fix_fn = mkIfaceFixCache fixities,
mi_hash_fn = mkIfaceHashCache decls })
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 }
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 env0 (ifaceDeclFingerprints v d)
where
add (occ,hash) env0 = extendOccEnv env0 occ (occ,hash)
emptyIfaceHashCache :: OccName -> Maybe (OccName, Fingerprint)
emptyIfaceHashCache _occ = Nothing
data ModDetails
= ModDetails {
md_exports :: [AvailInfo],
md_types :: !TypeEnv,
md_insts :: ![ClsInst],
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 :: ![ClsInst],
mg_fam_insts :: ![FamInst],
mg_patsyns :: ![PatSyn],
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}
%* *
%************************************************************************
Note [The interactive package]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Type and class declarations at the command prompt are treated as if
they were defined in modules
interactive:Ghci1
interactive:Ghci2
...etc...
with each bunch of declarations using a new module, all sharing a
common package 'interactive' (see Module.interactivePackageId, and
PrelNames.mkInteractiveModule).
This scheme deals well with shadowing. For example:
ghci> data T = A
ghci> data T = B
ghci> :i A
data Ghci1.T = A -- Defined at :2:10
Here we must display info about constructor A, but its type T has been
shadowed by the second declaration. But it has a respectable
qualified name (Ghci1.T), and its source location says where it was
defined.
So the main invariant continues to hold, that in any session an
original name M.T only refers to one unique thing. (In a previous
iteration both the T's above were called :Interactive.T, albeit with
different uniques, which gave rise to all sorts of trouble.)
The details are a bit tricky though:
* The field ic_mod_index counts which Ghci module we've got up to.
It is incremented when extending ic_tythings
* ic_tythings contains only things from the 'interactive' package.
* Module from the 'interactive' package (Ghci1, Ghci2 etc) never go
in the Home Package Table (HPT). When you say :load, that's when we
extend the HPT.
* The 'thisPackage' field of DynFlags is *not* set to 'interactive'.
It stays as 'main' (or whatever -package-name says), and is the
package to which :load'ed modules are added to.
* So how do we arrange that declarations at the command prompt get
to be in the 'interactive' package? Simply by setting the tcg_mod
field of the TcGblEnv to "interactive:Ghci1". This is done by the
call to initTc in initTcInteractive, initTcForLookup, which in
turn get the module from it 'icInteractiveModule' field of the
interactive context.
The 'thisPackage' field stays as 'main' (or whatever -package-name says.
* The main trickiness is that the type environment (tcg_type_env and
fixity envt (tcg_fix_env) now contains entities from all the
GhciN modules together, rather than just a single module as is usually
the case. So you can't use "nameIsLocalOrFrom" to decide whether
to look in the TcGblEnv vs the HPT/PTE. This is a change, but not
a problem provided you know.
Note [Interactively-bound Ids in GHCi]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The Ids bound by previous Stmts in GHCi are currently
a) GlobalIds
b) with an Internal Name (not External)
c) and a tidied type
(a) They must be GlobalIds (not LocalIds) otherwise when we come to
compile an expression using these ids later, the byte code
generator will consider the occurrences to be free rather than
global.
(b) They start with an Internal Name because a Stmt is a local
construct, so the renamer naturally builds an Internal name for
each of its binders. It would be possible subsequently to give
them an External Name (in a GhciN module) but then we'd have
to substitute it out. So for now they stay Internal.
(c) Their types are tidied. This is important, because :info may ask
to look at them, and :info expects the things it looks up to have
tidy types
However note that TyCons, Classes, and even Ids bound by other top-level
declarations in GHCi (eg foreign import, record selectors) currently get
External Names, with Ghci9 (or 8, or 7, etc) as the module name.
Note [ic_tythings]
~~~~~~~~~~~~~~~~~~
The ic_tythings field contains
* The TyThings declared by the user at the command prompt
(eg Ids, TyCons, Classes)
* The user-visible Ids that arise from such things, which
*don't* come from 'implicitTyThings', notably:
- record selectors
- class ops
The implicitTyThings are readily obtained from the TyThings
but record selectors etc are not
It does *not* contain
* DFunIds (they can be gotten from ic_instances)
* CoAxioms (ditto)
See also Note [Interactively-bound Ids in GHCi]
\begin{code}
data InteractiveContext
= InteractiveContext {
ic_dflags :: DynFlags,
ic_mod_index :: Int,
ic_imports :: [InteractiveImport],
ic_tythings :: [TyThing],
ic_rn_gbl_env :: GlobalRdrEnv,
ic_instances :: ([ClsInst], [FamInst]),
ic_fix_env :: FixityEnv,
ic_default :: Maybe [Type],
#ifdef GHCI
ic_resume :: [Resume],
#endif
ic_monad :: Name,
ic_int_print :: Name,
ic_cwd :: Maybe FilePath
}
data InteractiveImport
= IIDecl (ImportDecl RdrName)
| IIModule ModuleName
emptyInteractiveContext :: DynFlags -> InteractiveContext
emptyInteractiveContext dflags
= InteractiveContext {
ic_dflags = dflags,
ic_imports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv,
ic_mod_index = 1,
ic_tythings = [],
ic_instances = ([],[]),
ic_fix_env = emptyNameEnv,
ic_monad = ioTyConName,
ic_int_print = printName,
ic_default = Nothing,
#ifdef GHCI
ic_resume = [],
#endif
ic_cwd = Nothing }
icInteractiveModule :: InteractiveContext -> Module
icInteractiveModule (InteractiveContext { ic_mod_index = index })
= mkInteractiveModule index
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
| null new_tythings
= ictxt
| otherwise
= ictxt { ic_mod_index = ic_mod_index ictxt + 1
, ic_tythings = new_tythings ++ old_tythings
, ic_rn_gbl_env = ic_rn_gbl_env ictxt `icExtendGblRdrEnv` new_tythings
}
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 ]
setInteractivePackage :: HscEnv -> HscEnv
setInteractivePackage hsc_env
= hsc_env { hsc_dflags = (hsc_dflags hsc_env) { thisPackage = interactivePackageId } }
setInteractivePrintName :: InteractiveContext -> Name -> InteractiveContext
setInteractivePrintName ic n = ic{ic_int_print = n}
icExtendGblRdrEnv :: GlobalRdrEnv -> [TyThing] -> GlobalRdrEnv
icExtendGblRdrEnv env tythings
= foldr add env tythings
where
add thing env = extendGlobalRdrEnv True env
[tyThingAvailInfo thing]
substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext
substInteractiveContext ictxt@InteractiveContext{ ic_tythings = tts } subst
| isEmptyTvSubst subst = ictxt
| otherwise = ictxt { ic_tythings = map subst_ty tts }
where
subst_ty (AnId id) = AnId $ id `setIdType` substTy subst (idType id)
subst_ty tt = tt
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 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
= NameNotInScope1
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}
%************************************************************************
%* *
Implicit TyThings
%* *
%************************************************************************
Note [Implicit TyThings]
~~~~~~~~~~~~~~~~~~~~~~~~
DEFINITION: An "implicit" TyThing is one that does not have its own
IfaceDecl in an interface file. Instead, its binding in the type
environment is created as part of typechecking the IfaceDecl for
some other thing.
Examples:
* All DataCons are implicit, because they are generated from the
IfaceDecl for the data/newtype. Ditto class methods.
* Record selectors are *not* implicit, because they get their own
free-standing IfaceDecl.
* Associated data/type families are implicit because they are
included in the IfaceDecl of the parent class. (NB: the
IfaceClass decl happens to use IfaceDecl recursively for the
associated types, but that's irrelevant here.)
* Dictionary function Ids are not implict.
* Axioms for newtypes are implicit (same as above), but axioms
for data/type family instances are *not* implicit (like DFunIds).
\begin{code}
implicitTyThings :: TyThing -> [TyThing]
implicitTyThings (AnId _) = []
implicitTyThings (ACoAxiom _cc) = []
implicitTyThings (ATyCon tc) = implicitTyConThings tc
implicitTyThings (AConLike cl) = implicitConLikeThings cl
implicitConLikeThings :: ConLike -> [TyThing]
implicitConLikeThings (RealDataCon dc)
= map AnId (dataConImplicitIds dc)
implicitConLikeThings (PatSynCon {})
= []
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 . AConLike . RealDataCon) (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
| Just co <- newTyConCo_maybe tc = [ACoAxiom $ toBranchedAxiom co]
| Just co <- isClosedSynFamilyTyCon_maybe tc
= [ACoAxiom co]
| otherwise = []
isImplicitTyThing :: TyThing -> Bool
isImplicitTyThing (AConLike cl) = case cl of
RealDataCon {} -> True
PatSynCon {} -> False
isImplicitTyThing (AnId id) = isImplicitId id
isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc
isImplicitTyThing (ACoAxiom ax) = isImplicitCoAxiom ax
tyThingParent_maybe :: TyThing -> Maybe TyThing
tyThingParent_maybe (AConLike cl) = case cl of
RealDataCon dc -> Just (ATyCon (dataConTyCon dc))
PatSynCon{} -> Nothing
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 (AConLike cl) = case cl of
RealDataCon dc -> tyVarsOfType $ dataConRepType dc
PatSynCon{} -> emptyVarSet
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 Branched]
typeEnvIds :: TypeEnv -> [Id]
typeEnvPatSyns :: TypeEnv -> [PatSyn]
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]
typeEnvPatSyns env = [ps | AConLike (PatSynCon ps) <- typeEnvElts env]
typeEnvDataCons env = [dc | AConLike (RealDataCon 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
++ map (ACoAxiom . toBranchedAxiom . famInstAxiom) famInsts
)
where
all_tcs = tcs ++ famInstsRepTyCons 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
| isOneShot (ghcMode dflags)
= lookupNameEnv pte name
| otherwise
= case lookupHptByModule hpt mod of
Just hm -> lookupNameEnv (md_types (hm_details hm)) name
Nothing -> lookupNameEnv pte name
where
mod = ASSERT2( isExternalName name, ppr name ) nameModule name
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 Branched
tyThingCoAxiom (ACoAxiom ax) = ax
tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other)
tyThingDataCon :: TyThing -> DataCon
tyThingDataCon (AConLike (RealDataCon dc)) = dc
tyThingDataCon other = pprPanic "tyThingDataCon" (pprTyThing other)
tyThingId :: TyThing -> Id
tyThingId (AnId id) = id
tyThingId (AConLike (RealDataCon 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}
%************************************************************************
%* *
\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 )
instance Binary Warnings where
put_ bh NoWarnings = putByte bh 0
put_ bh (WarnAll t) = do
putByte bh 1
put_ bh t
put_ bh (WarnSome ts) = do
putByte bh 2
put_ bh ts
get bh = do
h <- getByte bh
case h of
0 -> return NoWarnings
1 -> do aa <- get bh
return (WarnAll aa)
_ -> do aa <- get bh
return (WarnSome aa)
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 )
instance Binary Dependencies where
put_ bh deps = do put_ bh (dep_mods deps)
put_ bh (dep_pkgs deps)
put_ bh (dep_orphs deps)
put_ bh (dep_finsts deps)
get bh = do ms <- get bh
ps <- get bh
os <- get bh
fis <- get bh
return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os,
dep_finsts = fis })
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_file_hash :: Fingerprint
}
deriving( Eq )
instance Binary Usage where
put_ bh usg@UsagePackageModule{} = do
putByte bh 0
put_ bh (usg_mod usg)
put_ bh (usg_mod_hash usg)
put_ bh (usg_safe usg)
put_ bh usg@UsageHomeModule{} = do
putByte bh 1
put_ bh (usg_mod_name usg)
put_ bh (usg_mod_hash usg)
put_ bh (usg_exports usg)
put_ bh (usg_entities usg)
put_ bh (usg_safe usg)
put_ bh usg@UsageFile{} = do
putByte bh 2
put_ bh (usg_file_path usg)
put_ bh (usg_file_hash usg)
get bh = do
h <- getByte bh
case h of
0 -> do
nm <- get bh
mod <- get bh
safe <- get bh
return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
1 -> do
nm <- get bh
mod <- get bh
exps <- get bh
ents <- get bh
safe <- get bh
return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
usg_exports = exps, usg_entities = ents, usg_safe = safe }
2 -> do
fp <- get bh
hash <- get bh
return UsageFile { usg_file_path = fp, usg_file_hash = hash }
i -> error ("Binary.get(Usage): " ++ show i)
\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
}
type OrigNameCache = ModuleEnv (OccEnv Name)
\end{code}
\begin{code}
mkSOName :: Platform -> FilePath -> FilePath
mkSOName platform root
= case platformOS platform of
OSDarwin -> ("lib" ++ root) <.> "dylib"
OSMinGW32 -> root <.> "dll"
_ -> ("lib" ++ root) <.> "so"
mkHsSOName :: Platform -> FilePath -> FilePath
mkHsSOName platform root = ("lib" ++ root) <.> soExt platform
soExt :: Platform -> FilePath
soExt platform
= case platformOS platform of
OSDarwin -> "dylib"
OSMinGW32 -> "dll"
_ -> "so"
\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 :: UTCTime,
ms_obj_date :: Maybe UTCTime,
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 :: DynFlags -> HscTarget -> Bool -> ModSummary -> String
showModMsg dflags target recomp mod_summary
= showSDoc dflags $
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 = showPpr dflags 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)
, vectInfoParallelVars :: VarSet
, vectInfoParallelTyCons :: NameSet
}
data IfaceVectInfo
= IfaceVectInfo
{ ifaceVectInfoVar :: [Name]
, ifaceVectInfoTyCon :: [Name]
, ifaceVectInfoTyConReuse :: [Name]
, ifaceVectInfoParallelVars :: [Name]
, ifaceVectInfoParallelTyCons :: [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)
(vectInfoParallelVars vi1 `unionVarSet` vectInfoParallelVars vi2)
(vectInfoParallelTyCons vi1 `unionNameSets` vectInfoParallelTyCons 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 "parallel vars :") <+> ppr (vectInfoParallelVars info)
, ptext (sLit "parallel tycons :") <+> ppr (vectInfoParallelTyCons info)
]
instance Binary IfaceVectInfo where
put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do
put_ bh a1
put_ bh a2
put_ bh a3
put_ bh a4
put_ bh a5
get bh = do
a1 <- get bh
a2 <- get bh
a3 <- get bh
a4 <- get bh
a5 <- get bh
return (IfaceVectInfo a1 a2 a3 a4 a5)
\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_SafeInferred -> 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_SafeInferred
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_SafeInferred) = ptext $ sLit "safe-inferred"
instance Binary IfaceTrustInfo where
put_ bh iftrust = putByte bh $ trustInfoToNum iftrust
get bh = getByte bh >>= (return . numToTrustInfo)
\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 :: UTCTime,
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}