\begin{code}
module HscTypes (
-- * Sessions and compilation state
- Session(..), HscEnv(..), hscEPS,
+ Session(..), withSession, modifySession,
+ HscEnv(..), hscEPS,
FinderCache, FindResult(..), ModLocationCache,
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
ModDetails(..), emptyModDetails,
ModGuts(..), CgGuts(..), ModImports(..), ForeignStubs(..),
- ModSummary(..), showModMsg, isBootSummary,
+ ModSummary(..), ms_mod_name, showModMsg, isBootSummary,
msHsFilePath, msHiFilePath, msObjFilePath,
HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases
lookupIfaceByModule, emptyModIface,
InteractiveContext(..), emptyInteractiveContext,
- icPrintUnqual, mkPrintUnqualified,
+ icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
emptyIfaceDepCache,
GenAvailInfo(..), AvailInfo, RdrAvailInfo,
IfaceExport,
- Deprecations, DeprecTxt, lookupDeprec, plusDeprecs,
+ Deprecations, DeprecTxt, plusDeprecs,
PackageInstEnv, PackageRuleBase,
-- Linker stuff
Linkable(..), isObjectLinkable,
Unlinked(..), CompiledByteCode,
- isObject, nameOfObject, isInterpretable, byteCodeOfObject
+ isObject, nameOfObject, isInterpretable, byteCodeOfObject,
+ HpcInfo(..), noHpcInfo,
+
+ -- Breakpoints
+ ModBreaks (..), BreakIndex, emptyModBreaks
) where
#include "HsVersions.h"
#ifdef GHCI
import ByteCodeAsm ( CompiledByteCode )
+import {-# SOURCE #-} InteractiveEval ( Resume )
#endif
-import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv,
- LocalRdrEnv, emptyLocalRdrEnv, GlobalRdrElt(..),
+import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, GlobalRdrElt(..),
unQualOK, ImpDeclSpec(..), Provenance(..),
ImportSpec(..), lookupGlobalRdrEnv )
import Name ( Name, NamedThing, getName, nameOccName, nameModule )
import FamInstEnv ( FamInstEnv, FamInst )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
-import Id ( Id, isImplicitId )
+import VarSet
+import Id
import Type ( TyThing(..) )
import Class ( Class, classSelIds, classATs, classTyCon )
import IfaceSyn
import FiniteMap ( FiniteMap )
import CoreSyn ( CoreRule )
-import Maybes ( orElse, expectJust )
+import Maybes ( orElse, expectJust, catMaybes, seqMaybe )
import Outputable
+import BreakArray
import SrcLoc ( SrcSpan, Located )
import UniqFM ( lookupUFM, eltsUFM, emptyUFM )
import UniqSupply ( UniqSupply )
import FastString ( FastString )
-import DATA_IOREF ( IORef, readIORef )
import StringBuffer ( StringBuffer )
-import Maybes ( catMaybes, seqMaybe )
-import Time ( ClockTime )
+
+import System.Time ( ClockTime )
+import Data.IORef
+import Data.Array ( Array, array )
\end{code}
-- constituting the current program or library, the context for
-- interactive evaluation, and various caches.
newtype Session = Session (IORef HscEnv)
+
+withSession :: Session -> (HscEnv -> IO a) -> IO a
+withSession (Session ref) f = do h <- readIORef ref; f h
+
+modifySession :: Session -> (HscEnv -> HscEnv) -> IO ()
+modifySession (Session ref) f = do h <- readIORef ref; writeIORef ref $! f h
\end{code}
HscEnv is like Session, except that some of the fields are immutable.
pprTarget :: Target -> SDoc
pprTarget (Target id _) = pprTargetId id
+instance Outputable Target where
+ ppr = pprTarget
+
pprTargetId (TargetModule m) = ppr m
pprTargetId (TargetFile f _) = text f
+instance Outputable TargetId where
+ ppr = pprTargetId
+
type HomePackageTable = ModuleNameEnv HomeModInfo
-- Domain = modules in the home package
-- "home" package name cached here for convenience
, mod /= moduleName gHC_PRIM
-- Look it up in the HPT
- , let mod_info = case lookupUFM hpt mod of
- Nothing -> pprPanic "hptRules" (ppr mod <+> ppr deps)
- Just x -> x
+ , let rules = case lookupUFM hpt mod of
+ Just info -> md_rules (hm_details info)
+ Nothing -> pprTrace "WARNING in hptRules" msg []
+ msg = vcat [ptext SLIT("missing module") <+> ppr mod,
+ ptext SLIT("Probable cause: out-of-date interface files")]
+ -- This really shouldn't happen, but see Trac #962
-- And get its dfuns
- , rule <- md_rules (hm_details mod_info) ]
+ , rule <- rules ]
\end{code}
%************************************************************************
mi_mod_vers :: !Version, -- Module version: changes when anything changes
mi_orphan :: !WhetherHasOrphans, -- Whether this module has orphans
+ mi_finsts :: !WhetherHasFamInst, -- Whether module has family insts
mi_boot :: !IsBootInterface, -- Read from an hi-boot file?
mi_deps :: Dependencies,
mi_fam_insts :: [IfaceFamInst], -- Sorted
mi_rules :: [IfaceRule], -- Sorted
mi_rule_vers :: !Version, -- Version number for rules and
- -- instances combined
+ -- instances (for classes and families)
+ -- combined
-- Cached environments for easy lookup
-- These are computed (lazily) from other fields
-- Should be able to construct ModDetails from mi_decls in ModIface
data ModDetails
= ModDetails {
- -- The next three fields are created by the typechecker
- md_exports :: [AvailInfo],
- md_types :: !TypeEnv,
- md_fam_insts :: ![FamInst], -- Cached value extracted from md_types
- md_insts :: ![Instance], -- Dfun-ids for the instances in this module
- md_rules :: ![CoreRule] -- Domain may include Ids from other modules
+ -- The next two fields are created by the typechecker
+ md_exports :: [AvailInfo],
+ md_types :: !TypeEnv,
+ md_insts :: ![Instance], -- Dfun-ids for the instances in this module
+ md_fam_insts :: ![FamInst],
+ md_rules :: ![CoreRule], -- Domain may include Ids from other modules
+ md_modBreaks :: !ModBreaks -- breakpoint information for this module
}
emptyModDetails = ModDetails { md_types = emptyTypeEnv,
md_exports = [],
md_insts = [],
md_rules = [],
- md_fam_insts = [] }
+ md_fam_insts = [],
+ md_modBreaks = emptyModBreaks }
-- A ModGuts is carried through the compiler, accumulating stuff as it goes
-- There is only one ModGuts at any time, the one for the module
mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment
mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in
-- this module
- mg_deprecs :: !Deprecations, -- Deprecations declared in the module
+
+ mg_fam_inst_env :: FamInstEnv, -- Type-family instance enviroment
+ -- for *home-package* modules (including
+ -- this one). c.f. tcg_fam_inst_env
mg_types :: !TypeEnv,
mg_insts :: ![Instance], -- Instances
mg_fam_insts :: ![FamInst], -- Instances
mg_rules :: ![CoreRule], -- Rules from this module
mg_binds :: ![CoreBind], -- Bindings for this module
- mg_foreign :: !ForeignStubs
+ mg_foreign :: !ForeignStubs,
+ mg_deprecs :: !Deprecations, -- Deprecations declared in the module
+ mg_hpc_info :: !HpcInfo, -- info about coverage tick boxes
+ mg_modBreaks :: !ModBreaks
}
-- The ModGuts takes on several slightly different forms:
-- initialisation code
cg_foreign :: !ForeignStubs,
- cg_dep_pkgs :: ![PackageId] -- Used to generate #includes for C code gen
+ cg_dep_pkgs :: ![PackageId], -- Used to generate #includes for C code gen
+ cg_hpc_info :: !HpcInfo -- info about coverage tick boxes
}
-----------------------------------
= ModIface { mi_module = mod,
mi_mod_vers = initialVersion,
mi_orphan = False,
+ mi_finsts = False,
mi_boot = False,
mi_deps = noDependencies,
mi_usages = [],
ic_rn_gbl_env :: GlobalRdrEnv, -- The cached GlobalRdrEnv, built from
-- ic_toplev_scope and ic_exports
- ic_rn_local_env :: LocalRdrEnv, -- Lexical context for variables bound
- -- during interaction
+ ic_tmp_ids :: [Id], -- Names bound during interaction.
+ -- Earlier Ids shadow
+ -- later ones with the same OccName.
+
+ ic_tyvars :: TyVarSet -- skolem type variables free in
+ -- ic_tmp_ids. These arise at
+ -- breakpoints in a polymorphic
+ -- context, where we have only partial
+ -- type information.
- ic_type_env :: TypeEnv -- Ditto for types
+#ifdef GHCI
+ , ic_resume :: [Resume] -- the stack of breakpoint contexts
+#endif
}
+
emptyInteractiveContext
= InteractiveContext { ic_toplev_scope = [],
ic_exports = [],
ic_rn_gbl_env = emptyGlobalRdrEnv,
- ic_rn_local_env = emptyLocalRdrEnv,
- ic_type_env = emptyTypeEnv }
+ ic_tmp_ids = [],
+ ic_tyvars = emptyVarSet
+#ifdef GHCI
+ , ic_resume = []
+#endif
+ }
icPrintUnqual :: InteractiveContext -> PrintUnqualified
icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt)
+
+
+extendInteractiveContext
+ :: InteractiveContext
+ -> [Id]
+ -> TyVarSet
+ -> InteractiveContext
+extendInteractiveContext ictxt ids tyvars
+ = ictxt { ic_tmp_ids = ids ++ ic_tmp_ids ictxt,
+ ic_tyvars = ic_tyvars ictxt `unionVarSet` tyvars }
\end{code}
%************************************************************************
concatMap (extras_plus . ADataCon)
(tyConDataCons tc)
- -- For classes, add the class TyCon too (and its extras)
- -- and the class selector Ids and the associated types (they don't
- -- have extras as these are only the family decls)
-implicitTyThings (AClass cl) = map AnId (classSelIds cl) ++
- map ATyCon (classATs cl) ++
- extras_plus (ATyCon (classTyCon cl))
+ -- For classes, add the class selector Ids, and assoicated TyCons
+ -- and the class TyCon too (and its extras)
+implicitTyThings (AClass cl)
+ = map AnId (classSelIds cl) ++
+ map ATyCon (classATs cl) ++
+ -- No extras_plus for the classATs, because they
+ -- are only the family decls; they have no implicit things
+ extras_plus (ATyCon (classTyCon cl))
-- For data cons add the worker and wrapper (if any)
implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc)
emptyIfaceDepCache :: Name -> Maybe DeprecTxt
emptyIfaceDepCache n = Nothing
-lookupDeprec :: Deprecations -> Name -> Maybe DeprecTxt
-lookupDeprec NoDeprecs name = Nothing
-lookupDeprec (DeprecAll txt) name = Just txt
-lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of
- Just (_, txt) -> Just txt
- Nothing -> Nothing
-
plusDeprecs :: Deprecations -> Deprecations -> Deprecations
plusDeprecs d NoDeprecs = d
plusDeprecs NoDeprecs d = d
ppr = pprAvail
pprAvail :: Outputable n => GenAvailInfo n -> SDoc
-pprAvail (AvailTC n ns) = ppr n <> case {- filter (/= n) -} ns of
- [] -> empty
- ns' -> braces (hsep (punctuate comma (map ppr ns')))
-
-pprAvail (Avail n) = ppr n
+pprAvail (Avail n) = ppr n
+pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns)))
\end{code}
\begin{code}
-- * a transformation rule in a module other than the one defining
-- the function in the head of the rule.
+type WhetherHasFamInst = Bool -- This module defines family instances?
+
type IsBootInterface = Bool
-- Dependency info about modules and packages below this one
-- in the import hierarchy. See TcRnTypes.ImportAvails for details.
+-- The orphan modules in `dep_orphs' do *not* include family instance orphans,
+-- as they are anyway included in `dep_finsts'.
--
-- Invariant: the dependencies of a module M never includes M
-- Invariant: the lists are unordered, with no duplicates
data Dependencies
- = Deps { dep_mods :: [(ModuleName,IsBootInterface)], -- Home-package module dependencies
- dep_pkgs :: [PackageId], -- External package dependencies
- dep_orphs :: [Module] } -- Orphan modules (whether home or external pkg)
+ = Deps { dep_mods :: [(ModuleName, -- Home-package module dependencies
+ IsBootInterface)]
+ , dep_pkgs :: [PackageId] -- External package dependencies
+ , dep_orphs :: [Module] -- Orphan modules (whether home or
+ -- external pkg)
+ , dep_finsts :: [Module] -- Modules that contain family
+ -- instances (whether home or
+ -- external pkg)
+ }
deriving( Eq )
-- Equality used only for old/new comparison in MkIface.addVersionInfo
noDependencies :: Dependencies
-noDependencies = Deps [] [] []
+noDependencies = Deps [] [] [] []
data Usage
= Usage { usg_name :: ModuleName, -- Name of the module
eps_fam_inst_env :: !PackageFamInstEnv,-- Ditto FamInstEnv
eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv
+ eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- identifies family
+ -- instances of each mod
+
eps_stats :: !EpsStats
}
ms_hspp_buf :: Maybe StringBuffer -- The actual preprocessed source, maybe.
}
+ms_mod_name :: ModSummary -> ModuleName
+ms_mod_name = moduleName . ms_mod
+
-- The ModLocation contains both the original source filename and the
-- filename of the cleaned-up source file after all preprocessing has been
-- done. The point is that the summariser will have to cpp/unlit/whatever
= showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '),
char '(', text (msHsFilePath mod_summary) <> comma,
case target of
- HscInterpreted | recomp
+ HscInterpreted | recomp
-> text "interpreted"
HscNothing -> text "nothing"
_other -> text (msObjFilePath mod_summary),
%************************************************************************
%* *
+\subsection{Hpc Support}
+%* *
+%************************************************************************
+
+\begin{code}
+data HpcInfo = HpcInfo
+ { hpcInfoTickCount :: Int
+ , hpcInfoHash :: Int
+ }
+ | NoHpcInfo
+
+noHpcInfo :: HpcInfo
+noHpcInfo = NoHpcInfo
+\end{code}
+
+%************************************************************************
+%* *
\subsection{Linkable stuff}
%* *
%************************************************************************
byteCodeOfObject other = pprPanic "byteCodeOfObject" (ppr other)
\end{code}
+%************************************************************************
+%* *
+\subsection{Breakpoint Support}
+%* *
+%************************************************************************
+\begin{code}
+type BreakIndex = Int
+
+-- | all the information about the breakpoints for a given module
+data ModBreaks
+ = ModBreaks
+ { modBreaks_flags :: BreakArray
+ -- The array of flags, one per breakpoint,
+ -- indicating which breakpoints are enabled.
+ , modBreaks_locs :: !(Array BreakIndex SrcSpan)
+ -- An array giving the source span of each breakpoint.
+ , modBreaks_vars :: !(Array BreakIndex [OccName])
+ -- An array giving the names of the free variables at each breakpoint.
+ }
+emptyModBreaks :: ModBreaks
+emptyModBreaks = ModBreaks
+ { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised"
+ -- Todo: can we avoid this?
+ , modBreaks_locs = array (0,-1) []
+ , modBreaks_vars = array (0,-1) []
+ }
+\end{code}