HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases
HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
- hptInstances, hptRules,
+ hptInstances, hptRules, hptVectInfo,
ExternalPackageState(..), EpsStats(..), addEpsInStats,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
InteractiveContext(..), emptyInteractiveContext,
icPrintUnqual, mkPrintUnqualified, extendInteractiveContext,
+ substInteractiveContext,
ModIface(..), mkIfaceDepCache, mkIfaceVerCache, mkIfaceFixCache,
emptyIfaceDepCache,
Linkable(..), isObjectLinkable,
Unlinked(..), CompiledByteCode,
isObject, nameOfObject, isInterpretable, byteCodeOfObject,
- HpcInfo(..), noHpcInfo,
+ HpcInfo(..), emptyHpcInfo, isHpcUsed, AnyHpcUsage,
-- Breakpoints
ModBreaks (..), BreakIndex, emptyModBreaks,
#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
import FamInstEnv ( FamInstEnv, FamInst )
import Rules ( RuleBase )
import CoreSyn ( CoreBind )
+import VarEnv
import VarSet
+import Var hiding ( setIdType )
import Id
-import Type ( TyThing(..) )
+import Type
import Class ( Class, classSelIds, classATs, classTyCon )
import TyCon
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}
-- 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}
%************************************************************************
-- 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
-- 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_modBreaks :: !ModBreaks -- breakpoint information for this module
+ 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,
md_insts = [],
md_rules = [],
md_fam_insts = [],
- md_modBreaks = emptyModBreaks }
+ 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
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
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}
-- 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}
%************************************************************************
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}
%************************************************************************
\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
-noHpcInfo :: HpcInfo
-noHpcInfo = NoHpcInfo
+emptyHpcInfo :: AnyHpcUsage -> HpcInfo
+emptyHpcInfo = NoHpcInfo
+
+isHpcUsed :: HpcInfo -> AnyHpcUsage
+isHpcUsed (HpcInfo {}) = True
+isHpcUsed (NoHpcInfo { hpcUsed = used }) = used
\end{code}
%************************************************************************
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 version
-data VectInfo = VectInfo {
- vectInfoCCVar :: NameSet
- }
+-- 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 {
- ifaceVectInfoCCVar :: [Name]
- }
+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 emptyNameSet
+noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv
plusVectInfo :: VectInfo -> VectInfo -> VectInfo
plusVectInfo vi1 vi2 =
- VectInfo (vectInfoCCVar vi1 `unionNameSets` vectInfoCCVar 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 []
+noIfaceVectInfo = IfaceVectInfo [] [] []
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff