From e5f78a4a5309b598d5195aa49a0bf7a206942cea Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Mon, 7 May 2007 11:03:36 +0000 Subject: [PATCH] Add VectInfo to HPT I am putting this patch (as the previous VectInfo patch) straight away into the head to avoid the kind of merging disaster we had with the FC branch. The patch does not interfere with any other functionality and hence should cause no harm in the head. --- compiler/iface/MkIface.lhs | 9 +++++---- compiler/iface/TcIface.lhs | 6 ++++++ compiler/main/HscMain.lhs | 7 ++++++- compiler/main/HscTypes.lhs | 22 +++++++++++++++++----- compiler/main/TidyPgm.lhs | 20 +++++++++++++++++--- 5 files changed, 51 insertions(+), 13 deletions(-) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index df5bc08..e3193bd 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -242,11 +242,11 @@ mkIface hsc_env maybe_old_iface mg_deps = deps, mg_rdr_env = rdr_env, mg_fix_env = fix_env, - mg_deprecs = src_deprecs, - mg_vect_info = vect_info }) + mg_deprecs = src_deprecs}) (ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, + md_vect_info = vect_info, md_types = type_env, md_exports = exports }) @@ -272,6 +272,7 @@ mkIface hsc_env maybe_old_iface ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts + ; iface_vect_info = flattenVectInfo vect_info ; intermediate_iface = ModIface { mi_module = this_mod, @@ -286,6 +287,8 @@ mkIface hsc_env maybe_old_iface mi_fam_insts= sortLe le_fam_inst iface_fam_insts, mi_rules = sortLe le_rule iface_rules, + mi_vect_info = iface_vect_info, + mi_fixities = fixities, mi_deprecs = deprecs, mi_globals = Just rdr_env, @@ -300,8 +303,6 @@ mkIface hsc_env maybe_old_iface mi_decls = deliberatelyOmitted "decls", mi_ver_fn = deliberatelyOmitted "ver_fn", - mi_vect_info = flattenVectInfo vect_info, - -- And build the cached values mi_dep_fn = mkIfaceDepCache deprecs, mi_fix_fn = mkIfaceFixCache fixities } diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 2e3c8ed..a90d069 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -40,6 +40,7 @@ import Var ( TyVar ) import qualified Var import Name import NameEnv +import NameSet import OccName import Module import UniqFM @@ -198,6 +199,10 @@ typecheckIface iface ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface) + -- Vectorisation information + ; let vect_info = VectInfo + (mkNameSet (ifaceVectInfoCCVar (mi_vect_info iface))) + -- Exports ; exports <- ifaceExportNames (mi_exports iface) @@ -208,6 +213,7 @@ typecheckIface iface , md_insts = insts , md_fam_insts = fam_insts , md_rules = rules + , md_vect_info = vect_info , md_exports = exports , md_modBreaks = emptyModBreaks } diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index b4026e8..282ec0f 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -682,9 +682,14 @@ hscFileCheck hsc_env mod_summary = do { md_insts = tcg_insts tc_result, md_fam_insts = tcg_fam_insts tc_result, md_modBreaks = emptyModBreaks, - md_rules = [panic "no rules"] } + md_rules = [panic "no rules"], -- Rules are CoreRules, not the -- RuleDecls we get out of the typechecker + md_vect_info = + panic "HscMain.hscFileCheck: no VectInfo" + -- VectInfo is added by the Core + -- vectorisation pass + } rnInfo = do decl <- tcg_rn_decls tc_result imports <- tcg_rn_imports tc_result let exports = tcg_rn_exports tc_result diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index eeea9d9..bf7d676 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -21,7 +21,7 @@ module HscTypes ( HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, + hptInstances, hptRules, hptVectInfo, ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -330,6 +330,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} %************************************************************************ @@ -475,10 +484,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_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, @@ -486,7 +496,9 @@ 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 diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index b001e1d..6b89b33 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -32,7 +32,7 @@ import Name ( Name, getOccName, nameOccName, mkInternalName, localiseName, isExternalName, nameSrcLoc, isWiredInName, getName ) -import NameSet ( NameSet, elemNameSet ) +import NameSet ( NameSet, elemNameSet, filterNameSet ) import IfaceEnv ( allocateGlobalBinder ) import NameEnv ( filterNameEnv, mapNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) @@ -142,6 +142,7 @@ mkBootModDetails hsc_env (ModGuts { mg_module = mod , md_rules = [] , md_exports = exports , md_modBreaks = modBreaks + , md_vect_info = noVectInfo }) } where @@ -243,6 +244,7 @@ tidyProgram hsc_env mg_insts = insts, mg_fam_insts = fam_insts, mg_binds = binds, mg_rules = imp_rules, + mg_vect_info = vect_info, mg_dir_imps = dir_imps, mg_deps = deps, mg_foreign = foreign_stubs, mg_hpc_info = hpc_info, @@ -285,6 +287,12 @@ tidyProgram hsc_env ; implicit_binds = getImplicitBinds type_env ; all_tidy_binds = implicit_binds ++ tidy_binds ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) + + ; tidy_vect_info = VectInfo + (filterNameSet (isElemId type_env) + (vectInfoCCVar vect_info)) + -- filter against `type_env', not `tidy_type_env', as we must + -- keep all implicit names } ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds @@ -305,8 +313,9 @@ tidyProgram hsc_env md_insts = tidy_insts, md_fam_insts = fam_insts, md_exports = exports, - md_modBreaks = modBreaks }) - + md_modBreaks = modBreaks, + md_vect_info = tidy_vect_info + }) } lookup_dfun type_env dfun_id @@ -314,6 +323,11 @@ lookup_dfun type_env dfun_id Just (AnId dfun_id') -> dfun_id' other -> pprPanic "lookup_dfun" (ppr dfun_id) +isElemId type_env name + = case lookupTypeEnv type_env name of + Just (AnId _) -> True + _ -> False + tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv -- The competed type environment is gotten from -- 1.7.10.4