X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=85cf73e2e1f61bf8d6da074e38a935a69cdccdb2;hp=2272c2e328d9e47dc60ec7c19984e1cbd800ba2c;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=ade40ed39b56cc7241d953e66d721b27564c54f9 diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 2272c2e..85cf73e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -6,7 +6,8 @@ \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, @@ -14,20 +15,21 @@ module HscTypes ( 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 HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, + hptInstances, hptRules, hptVectInfo, ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, lookupIfaceByModule, emptyModIface, InteractiveContext(..), emptyInteractiveContext, - icPrintUnqual, mkPrintUnqualified, + icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, + substInteractiveContext, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, emptyIfaceDepCache, @@ -59,20 +61,26 @@ module HscTypes ( Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, - HpcInfo, noHpcInfo + HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, + + -- Breakpoints + ModBreaks (..), BreakIndex, emptyModBreaks, + + -- Vectorisation information + VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, + noIfaceVectInfo ) where #include "HsVersions.h" -import Breakpoints ( SiteNumber, Coord, noDbgSites ) #ifdef GHCI import ByteCodeAsm ( CompiledByteCode ) +import {-# SOURCE #-} InteractiveEval ( Resume ) #endif -import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, - LocalRdrEnv, emptyLocalRdrEnv, GlobalRdrElt(..), - unQualOK, ImpDeclSpec(..), Provenance(..), - ImportSpec(..), lookupGlobalRdrEnv ) +import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, GlobalRdrElt(..), + mkRdrUnqual, ImpDeclSpec(..), Provenance(..), + ImportSpec(..), lookupGlobalRdrEnv, lookupGRE_RdrName ) import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet @@ -83,8 +91,11 @@ import InstEnv ( InstEnv, Instance ) import FamInstEnv ( FamInstEnv, FamInst ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) -import Id ( Id, isImplicitId ) -import Type ( TyThing(..) ) +import VarEnv +import VarSet +import Var hiding ( setIdType ) +import Id +import Type import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon @@ -100,15 +111,17 @@ 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 ) import FastString ( FastString ) - import StringBuffer ( StringBuffer ) import System.Time ( ClockTime ) -import Data.IORef ( IORef, readIORef ) +import Data.IORef +import Data.Array ( Array, array ) +import Data.List \end{code} @@ -125,6 +138,12 @@ import Data.IORef ( IORef, readIORef ) -- 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. @@ -270,16 +289,19 @@ lookupIfaceByModule dflags hpt pit mod \begin{code} -hptInstances :: HscEnv -> (ModuleName -> Bool) -> [Instance] --- Find all the instance declarations that are in modules imported --- by this one, directly or indirectly, and are in the Home Package Table --- This ensures that we don't see instances from modules --make compiled --- before this one, but which are not below this one +hptInstances :: HscEnv -> (ModuleName -> Bool) -> ([Instance], [FamInst]) +-- Find all the instance declarations (of classes and families) that are in +-- modules imported by this one, directly or indirectly, and are in the Home +-- Package Table. This ensures that we don't see instances from modules --make +-- compiled before this one, but which are not below this one. hptInstances hsc_env want_this_module - = [ ispec - | mod_info <- eltsUFM (hsc_HPT hsc_env) - , want_this_module (moduleName (mi_module (hm_iface mod_info))) - , ispec <- md_insts (hm_details mod_info) ] + = let (insts, famInsts) = unzip + [ (md_insts details, md_fam_insts details) + | mod_info <- eltsUFM (hsc_HPT hsc_env) + , want_this_module (moduleName (mi_module (hm_iface mod_info))) + , let details = hm_details mod_info ] + in + (concat insts, concat famInsts) hptRules :: HscEnv -> [(ModuleName, IsBootInterface)] -> [CoreRule] -- Get rules from modules "below" this one (in the dependency sense) @@ -311,6 +333,15 @@ hptRules hsc_env deps -- And get its dfuns , rule <- rules ] + +hptVectInfo :: HscEnv -> VectInfo +-- Get the combined VectInfo of all modules in the home package table. In +-- contrast to instances and rules, we don't care whether the modules are +-- "below" or us. The VectInfo of those modules not "below" us does not +-- affect the compilation of the current module. +hptVectInfo hsc_env + = foldr plusVectInfo noVectInfo [ md_vect_info (hm_details mod_info) + | mod_info <- eltsUFM (hsc_HPT hsc_env)] \end{code} %************************************************************************ @@ -434,17 +465,22 @@ data ModIface -- instances (for classes and families) -- combined + -- Vectorisation information + mi_vect_info :: !IfaceVectInfo, + -- Cached environments for easy lookup -- These are computed (lazily) from other fields -- and are not put into the interface file mi_dep_fn :: Name -> Maybe DeprecTxt, -- Cached lookup for mi_deprecs mi_fix_fn :: OccName -> Fixity, -- Cached lookup for mi_fixities - mi_ver_fn :: OccName -> Maybe (OccName, Version) + mi_ver_fn :: OccName -> Maybe (OccName, Version), -- Cached lookup for mi_decls -- The Nothing in mi_ver_fn means that the thing -- isn't in decls. It's useful to know that when -- seeing if we are up to date wrt the old interface -- The 'OccName' is the parent of the name, if it has one. + mi_hpc :: !AnyHpcUsage + -- True if this program uses Hpc at any point in the program. } -- Should be able to construct ModDetails from mi_decls in ModIface @@ -453,10 +489,11 @@ data ModDetails -- 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_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_rules :: ![CoreRule], -- Domain may include Ids from other modules + md_modBreaks :: !ModBreaks, -- Breakpoint information for this module + md_vect_info :: !VectInfo -- Vectorisation information } emptyModDetails = ModDetails { md_types = emptyTypeEnv, @@ -464,7 +501,9 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], md_rules = [], md_fam_insts = [], - md_dbg_sites = noDbgSites} + md_modBreaks = emptyModBreaks, + md_vect_info = noVectInfo + } -- 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 @@ -486,9 +525,12 @@ data ModGuts mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in -- this module + mg_inst_env :: InstEnv, -- Class instance enviroment fro + -- *home-package* modules (including + -- this one); c.f. tcg_inst_env mg_fam_inst_env :: FamInstEnv, -- Type-family instance enviroment -- for *home-package* modules (including - -- this one). c.f. tcg_fam_inst_env + -- this one); c.f. tcg_fam_inst_env mg_types :: !TypeEnv, mg_insts :: ![Instance], -- Instances @@ -498,7 +540,8 @@ 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, + mg_vect_info :: !VectInfo -- Pool of vectorised declarations } -- The ModGuts takes on several slightly different forms: @@ -585,9 +628,11 @@ emptyModIface mod mi_decls = [], mi_globals = Nothing, mi_rule_vers = initialVersion, + mi_vect_info = noIfaceVectInfo, mi_dep_fn = emptyIfaceDepCache, mi_fix_fn = emptyIfaceFixCache, - mi_ver_fn = emptyIfaceVerCache + mi_ver_fn = emptyIfaceVerCache, + mi_hpc = False } \end{code} @@ -610,21 +655,63 @@ 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_tmp_ids :: [Id], -- Names bound during interaction. + -- Later Ids shadow + -- earlier 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 = ic_tmp_ids ictxt ++ ids, + -- NB. must be this way around, because we want + -- new ids to shadow existing bindings. + ic_tyvars = ic_tyvars ictxt `unionVarSet` tyvars } + + +substInteractiveContext :: InteractiveContext -> TvSubst -> InteractiveContext +substInteractiveContext ictxt subst | isEmptyTvSubst subst = ictxt +substInteractiveContext ictxt@InteractiveContext{ic_tmp_ids=ids} subst = + let ids' = map (\id -> id `setIdType` substTy subst (idType id)) ids + subst_dom= varEnvKeys$ getTvSubstEnv subst + subst_ran= varEnvElts$ getTvSubstEnv subst + new_tvs = [ tv | Just tv <- map getTyVar_maybe subst_ran] + ic_tyvars'= (`delVarSetListByKey` subst_dom) + . (`extendVarSetList` new_tvs) + $ ic_tyvars ictxt + in ictxt { ic_tmp_ids = ids' + , ic_tyvars = ic_tyvars' } + + where delVarSetListByKey = foldl' delVarSetByKey \end{code} %************************************************************************ @@ -637,19 +724,28 @@ icPrintUnqual ictxt = mkPrintUnqualified (ic_rn_gbl_env ictxt) mkPrintUnqualified :: GlobalRdrEnv -> PrintUnqualified mkPrintUnqualified env = (qual_name, qual_mod) where - qual_name mod occ - | null gres = Just (moduleName mod) + qual_name mod occ -- The (mod,occ) pair is the original name of the thing + | [gre] <- unqual_gres, right_name gre = Nothing + -- If there's a unique entity that's in scope unqualified with 'occ' + -- AND that entity is the right one, then we can use the unqualified name + + | [gre] <- qual_gres = Just (get_qual_mod (gre_prov gre)) + + | null qual_gres = Just (moduleName mod) -- it isn't in scope at all, this probably shouldn't happen, -- but we'll qualify it by the original module anyway. - | any unQualOK gres = Nothing - | (Imported is : _) <- map gre_prov gres, (idecl : _) <- is - = Just (is_as (is_decl idecl)) - | otherwise = panic "mkPrintUnqualified" + + | otherwise = panic "mkPrintUnqualified" where - gres = [ gre | gre <- lookupGlobalRdrEnv env occ, - nameModule (gre_name gre) == mod ] + right_name gre = nameModule (gre_name gre) == mod - qual_mod mod = Nothing -- For now... + 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 = Nothing -- For now, we never qualify module names with their packages \end{code} @@ -985,6 +1081,7 @@ type PackageTypeEnv = TypeEnv type PackageRuleBase = RuleBase type PackageInstEnv = InstEnv type PackageFamInstEnv = FamInstEnv +type PackageVectInfo = VectInfo data ExternalPackageState = EPS { @@ -1021,10 +1118,10 @@ data ExternalPackageState -- modules eps_fam_inst_env :: !PackageFamInstEnv,-- Ditto FamInstEnv eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv + eps_vect_info :: !PackageVectInfo, -- Ditto VectInfo eps_mod_fam_inst_env :: !(ModuleEnv FamInstEnv), -- identifies family - -- instances of each mod - + -- instances of each mod eps_stats :: !EpsStats } @@ -1106,6 +1203,9 @@ data ModSummary 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 @@ -1140,7 +1240,7 @@ 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 - HscInterpreted | recomp + HscInterpreted | recomp -> text "interpreted" HscNothing -> text "nothing" _other -> text (msObjFilePath mod_summary), @@ -1158,10 +1258,84 @@ showModMsg target recomp mod_summary %************************************************************************ \begin{code} -type HpcInfo = Int -- just the number of ticks in a module +data HpcInfo + = HpcInfo + { hpcInfoTickCount :: Int + , hpcInfoHash :: Int + } + | NoHpcInfo + { hpcUsed :: AnyHpcUsage -- is hpc used anywhere on the module tree? + } -noHpcInfo :: HpcInfo -noHpcInfo = 0 -- default = 0 +-- This is used to mean there is no module-local hpc usage, +-- but one of my imports used hpc instrumentation. + +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} +-- ModGuts/ModDetails/EPS version +data VectInfo + = VectInfo { + vectInfoVar :: VarEnv (Var , Var ), -- (f, f_v) keyed on f + vectInfoTyCon :: NameEnv (TyCon , TyCon), -- (T, T_v) keyed on T + vectInfoDataCon :: NameEnv (DataCon, DataCon), -- (C, C_v) keyed on C + vectInfoIso :: NameEnv (TyCon , Var) -- (T, isoT) keyed on T + } + -- all of this is always tidy, even in ModGuts + +-- ModIface version +data IfaceVectInfo + = IfaceVectInfo { + ifaceVectInfoVar :: [Name], + -- all variables in here have a vectorised variant; + -- the name of the vectorised variant is determined by `mkCloVect' + ifaceVectInfoTyCon :: [Name], + -- all tycons in here have a vectorised variant; + -- the name of the vectorised variant and those of its + -- data constructors are determined by `mkVectTyConOcc' + -- and `mkVectDataConOcc'; the names of + -- the isomorphisms is determined by `mkVectIsoOcc' + ifaceVectInfoTyConReuse :: [Name] + -- the vectorised form of all the tycons in here coincids with + -- the unconverted from; the names of the isomorphisms is determined + -- by `mkVectIsoOcc' + } + +noVectInfo :: VectInfo +noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv + +plusVectInfo :: VectInfo -> VectInfo -> VectInfo +plusVectInfo vi1 vi2 = + VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2) + (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2) + (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2) + (vectInfoIso vi1 `plusNameEnv` vectInfoIso vi2) + +noIfaceVectInfo :: IfaceVectInfo +noIfaceVectInfo = IfaceVectInfo [] [] [] \end{code} %************************************************************************ @@ -1232,5 +1406,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}