X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FHscTypes.lhs;h=cb5022e36876152bb155587c6b44934becf49a10;hb=663b391470a783e8f23414c07c18a020850d2fb8;hp=956d10d30bba5883a48e24a5b9e867bef9f0066d;hpb=098f818b622e5095fbd3f6318a463fcb2ce14fc6;p=ghc-hetmet.git diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 956d10d..cb5022e 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -29,6 +29,7 @@ module HscTypes ( InteractiveContext(..), emptyInteractiveContext, icPrintUnqual, mkPrintUnqualified, extendInteractiveContext, + substInteractiveContext, ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache, emptyIfaceDepCache, @@ -60,7 +61,7 @@ module HscTypes ( Linkable(..), isObjectLinkable, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, - HpcInfo(..), noHpcInfo, + HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage, -- Breakpoints ModBreaks (..), BreakIndex, emptyModBreaks, @@ -78,8 +79,8 @@ import {-# SOURCE #-} InteractiveEval ( Resume ) #endif import RdrName ( GlobalRdrEnv, emptyGlobalRdrEnv, GlobalRdrElt(..), - unQualOK, ImpDeclSpec(..), Provenance(..), - ImportSpec(..), lookupGlobalRdrEnv ) + mkRdrUnqual, ImpDeclSpec(..), Provenance(..), + ImportSpec(..), lookupGlobalRdrEnv, lookupGRE_RdrName ) import Name ( Name, NamedThing, getName, nameOccName, nameModule ) import NameEnv import NameSet @@ -92,9 +93,9 @@ import Rules ( RuleBase ) import CoreSyn ( CoreBind ) import VarEnv import VarSet -import Var +import Var hiding ( setIdType ) import Id -import Type ( TyThing(..) ) +import Type import Class ( Class, classSelIds, classATs, classTyCon ) import TyCon @@ -115,12 +116,12 @@ 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 import Data.Array ( Array, array ) +import Data.List \end{code} @@ -472,12 +473,14 @@ data ModIface -- 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 @@ -519,13 +522,9 @@ data ModGuts mg_usages :: ![Usage], -- Version info for what it needed mg_rdr_env :: !GlobalRdrEnv, -- Top-level lexical environment - mg_fix_env :: !FixityEnv, -- Fixity env, for things declared in - -- this module - - mg_fam_inst_env :: FamInstEnv, -- Type-family instance enviroment - -- for *home-package* modules (including - -- this one). c.f. tcg_fam_inst_env + -- These fields all describe the things **declared in this module** + mg_fix_env :: !FixityEnv, -- Fixities mg_types :: !TypeEnv, mg_insts :: ![Instance], -- Instances mg_fam_insts :: ![FamInst], -- Instances @@ -535,7 +534,19 @@ data ModGuts mg_deprecs :: !Deprecations, -- Deprecations declared in the module mg_hpc_info :: !HpcInfo, -- info about coverage tick boxes mg_modBreaks :: !ModBreaks, - mg_vect_info :: !VectInfo -- Pool of vectorised declarations + mg_vect_info :: !VectInfo, -- Pool of vectorised declarations + + -- The next two fields are unusual, because they give instance + -- environments for *all* modules in the home package, including + -- this module, rather than for *just* this module. + -- Reason: when looking up an instance we don't want to have to + -- look at each module in the home package in turn + 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 } -- The ModGuts takes on several slightly different forms: @@ -597,8 +608,6 @@ data ForeignStubs = NoStubs -- "foreign exported" functions [FastString] -- Headers that need to be included -- into C code generated for this module - [Id] -- Foreign-exported binders - -- we have to generate code to register these \end{code} @@ -625,7 +634,8 @@ emptyModIface mod 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} @@ -689,6 +699,22 @@ extendInteractiveContext ictxt ids tyvars -- 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} %************************************************************************ @@ -701,19 +727,28 @@ extendInteractiveContext ictxt ids tyvars 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 + + unqual_gres = lookupGRE_RdrName (mkRdrUnqual occ) env + qual_gres = filter right_name (lookupGlobalRdrEnv env occ) - qual_mod mod = Nothing -- For now... + 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} @@ -1226,14 +1261,26 @@ showModMsg target recomp mod_summary %************************************************************************ \begin{code} -data HpcInfo = HpcInfo +data HpcInfo + = HpcInfo { hpcInfoTickCount :: Int , hpcInfoHash :: Int } - | NoHpcInfo + | NoHpcInfo + { hpcUsed :: AnyHpcUsage -- is hpc used anywhere on the module tree? + } + +-- 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 -noHpcInfo :: HpcInfo -noHpcInfo = NoHpcInfo +isHpcUsed :: HpcInfo -> AnyHpcUsage +isHpcUsed (HpcInfo {}) = True +isHpcUsed (NoHpcInfo { hpcUsed = used }) = used \end{code} %************************************************************************ @@ -1246,37 +1293,54 @@ 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_CC in the ModGuts/ModDetails/EPS version VectInfo +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 -closure conversion, we need to know `f_CC', whose `Var' we cannot lookup based +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 { - vectInfoCCVar :: VarEnv (Var, Var) -- (f, f_CC) keyed on f - -- always tidy, even in ModGuts + 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 + vectInfoPADFun :: NameEnv (TyCon , Var), -- (T_v, paT) keyed on T_v + vectInfoIso :: NameEnv (TyCon , Var) -- (T, isoT) keyed on T } + -- all of this is always tidy, even in ModGuts -- ModIface version data IfaceVectInfo = IfaceVectInfo { - ifaceVectInfoCCVar :: [Name] -- all variables in here have - -- a closure-converted variant - -- the name of the CC'ed variant - -- is determined by `mkCloOcc' + 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 +noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv plusVectInfo :: VectInfo -> VectInfo -> VectInfo plusVectInfo vi1 vi2 = - VectInfo (vectInfoCCVar vi1 `plusVarEnv` vectInfoCCVar vi2) + VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2) + (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2) + (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2) + (vectInfoPADFun vi1 `plusNameEnv` vectInfoPADFun vi2) + (vectInfoIso vi1 `plusNameEnv` vectInfoIso vi2) noIfaceVectInfo :: IfaceVectInfo -noIfaceVectInfo = IfaceVectInfo [] +noIfaceVectInfo = IfaceVectInfo [] [] [] \end{code} %************************************************************************ @@ -1366,6 +1430,8 @@ data ModBreaks -- 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. + , modBreaks_decls:: !(Array BreakIndex SrcSpan) + -- An array giving the span of the enclosing expression } emptyModBreaks :: ModBreaks @@ -1374,5 +1440,6 @@ emptyModBreaks = ModBreaks -- Todo: can we avoid this? , modBreaks_locs = array (0,-1) [] , modBreaks_vars = array (0,-1) [] + , modBreaks_decls= array (0,-1) [] } \end{code}