X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=78dd841b1232c63cc29ee4068290e127ff50e899;hb=71e037d119b8e7d05884cc149ac851243ee62bd4;hp=92b7228dd50cba4c7051315ce2f64e89646acade;hpb=d6b899273f0993030b33a7278329ba8b27f3b6e0;p=ghc-hetmet.git diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 92b7228..78dd841 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -27,7 +27,7 @@ module HscTypes ( lookupIfaceByModule, emptyModIface, InteractiveContext(..), emptyInteractiveContext, - icPrintUnqual, mkPrintUnqualified, + icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, emptyIfaceDepCache, @@ -59,12 +59,14 @@ module HscTypes ( Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, - HpcInfo, noHpcInfo + HpcInfo, noHpcInfo, + + -- Breakpoints + ModBreaks (..), BreakIndex, emptyModBreaks ) where #include "HsVersions.h" -import Breakpoints ( SiteNumber, Coord, noDbgSites ) #ifdef GHCI import ByteCodeAsm ( CompiledByteCode ) #endif @@ -83,7 +85,8 @@ import InstEnv ( InstEnv, Instance ) 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 ) @@ -100,6 +103,7 @@ import FiniteMap ( FiniteMap ) import CoreSyn ( CoreRule ) import Maybes ( orElse, expectJust, catMaybes, seqMaybe ) import Outputable +import BreakArray import SrcLoc ( SrcSpan, Located ) import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) @@ -109,6 +113,7 @@ import StringBuffer ( StringBuffer ) import System.Time ( ClockTime ) import Data.IORef ( IORef, readIORef ) +import Data.Array ( Array, array ) \end{code} @@ -456,7 +461,7 @@ data ModDetails 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_dbg_sites :: ![(SiteNumber, Coord)] -- Breakpoint sites inserted by the renamer + md_modBreaks :: !ModBreaks -- breakpoint information for this module } emptyModDetails = ModDetails { md_types = emptyTypeEnv, @@ -464,7 +469,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], md_rules = [], md_fam_insts = [], - md_dbg_sites = noDbgSites} + 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 @@ -498,7 +503,7 @@ data ModGuts mg_foreign :: !ForeignStubs, mg_deprecs :: !Deprecations, -- Deprecations declared in the module mg_hpc_info :: !HpcInfo, -- info about coverage tick boxes - mg_dbg_sites :: ![(SiteNumber, Coord)] -- Bkpts inserted by the renamer + mg_modBreaks :: !ModBreaks } -- The ModGuts takes on several slightly different forms: @@ -610,21 +615,51 @@ data InteractiveContext 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_type_env :: TypeEnv -- Ditto for types + ic_type_env :: TypeEnv, -- Type env for names bound during + -- interaction. NB. the names from + -- these Ids are used to populate + -- the LocalRdrEnv used during + -- typechecking of a statement, so + -- there should be no duplicate + -- names in here. + + ic_tyvars :: TyVarSet -- skolem type variables free in + -- ic_type_env. These arise at + -- breakpoints in a polymorphic + -- context, where we have only partial + -- type information. } emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], ic_exports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, - ic_rn_local_env = emptyLocalRdrEnv, - ic_type_env = emptyTypeEnv } + ic_type_env = emptyTypeEnv, + ic_tyvars = emptyVarSet } icPrintUnqual :: InteractiveContext -> PrintUnqualified icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt) + + +extendInteractiveContext + :: InteractiveContext + -> [Id] + -> TyVarSet + -> InteractiveContext +extendInteractiveContext ictxt ids tyvars + = ictxt { ic_type_env = extendTypeEnvWithIds filtered_type_env ids, + ic_tyvars = ic_tyvars ictxt `unionVarSet` tyvars } + where + type_env = ic_type_env ictxt + bound_names = map idName ids + -- Remove any shadowed bindings from the type_env; + -- we aren't allowed any duplicates because the LocalRdrEnv is + -- build directly from the Ids in the type env in here. + old_bound_names = map idName (typeEnvIds type_env) + shadowed = [ n | name <- bound_names, + n <- old_bound_names, + nameOccName name == nameOccName n ] + filtered_type_env = delListFromNameEnv type_env shadowed \end{code} %************************************************************************ @@ -1140,11 +1175,6 @@ showModMsg target recomp mod_summary = showSDoc (hsep [text (mod_str ++ replicate (max 0 (16 - length mod_str)) ' '), char '(', text (msHsFilePath mod_summary) <> comma, case target of -#if defined(GHCI) && defined(DEBUGGER) - HscInterpreted | recomp && - Opt_Debugging `elem` modflags - -> text "interpreted(debugging)" -#endif HscInterpreted | recomp -> text "interpreted" HscNothing -> text "nothing" @@ -1153,7 +1183,6 @@ showModMsg target recomp mod_summary where mod = moduleName (ms_mod mod_summary) mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) - modflags= flags(ms_hspp_opts mod_summary) \end{code} @@ -1238,5 +1267,32 @@ byteCodeOfObject (BCOs bc) = bc 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}