From 098f818b622e5095fbd3f6318a463fcb2ce14fc6 Mon Sep 17 00:00:00 2001 From: Manuel M T Chakravarty Date: Tue, 8 May 2007 08:06:09 +0000 Subject: [PATCH] Improved VectInfo - We need to keep pairs of (f, f_CC) in VectInfo as it is difficult to obtain Names from OccNames (of imported modules) in Core passes. - There is a choice of keeping Names or Vars in VectInfo. We go with Vars for now; mainly to avoid converting between Names and Vars repeatedly for the same VectInfo in other than one-shot mode. Again goes to the HEAD straight away to avoid conflicts down the road. --- compiler/iface/LoadIface.lhs | 14 ++++++++------ compiler/iface/MkIface.lhs | 5 ++++- compiler/iface/TcIface.hi-boot-6 | 1 + compiler/iface/TcIface.lhs | 38 +++++++++++++++++++++++++++++++++----- compiler/iface/TcIface.lhs-boot | 3 +++ compiler/main/HscTypes.lhs | 31 ++++++++++++++++++++++--------- compiler/main/TidyPgm.lhs | 15 ++------------- 7 files changed, 73 insertions(+), 34 deletions(-) diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index 00e9e7a..1c8b410 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -19,7 +19,7 @@ module LoadIface ( #include "HsVersions.h" import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRules, tcIfaceInst, - tcIfaceFamInst ) + tcIfaceFamInst, tcIfaceVectInfo ) import DynFlags import IfaceSyn @@ -239,6 +239,8 @@ loadInterface doc_str mod from ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) + ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) + (mi_vect_info iface) ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT", @@ -246,11 +248,6 @@ loadInterface doc_str mod from mi_fam_insts = panic "No mi_fam_insts in PIT", mi_rules = panic "No mi_rules in PIT" } - ; new_eps_vect_info = - VectInfo { - vectInfoCCVar = mkNameSet - (ifaceVectInfoCCVar . mi_vect_info $ iface) - } } ; updateEps_ $ \ eps -> @@ -587,6 +584,7 @@ pprModIface iface , vcat (map ppr (mi_insts iface)) , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) + , pprVectInfo (mi_vect_info iface) , pprDeprecs (mi_deprecs iface) ] where @@ -659,6 +657,10 @@ pprFixities fixes = ptext SLIT("fixities") <+> pprWithCommas pprFix fixes where pprFix (occ,fix) = ppr fix <+> ppr occ +pprVectInfo :: IfaceVectInfo -> SDoc +pprVectInfo (IfaceVectInfo names) = + ptext SLIT("Closured converted:") <+> hsep (map ppr names) + pprDeprecs NoDeprecs = empty pprDeprecs (DeprecAll txt) = ptext SLIT("Deprecate all") <+> doubleQuotes (ftext txt) pprDeprecs (DeprecSome prs) = ptext SLIT("Deprecate") <+> vcat (map pprDeprec prs) diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index e3193bd..811af49 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -195,6 +195,8 @@ import TcRnMonad import HscTypes import DynFlags +import VarEnv +import Var import Name import NameEnv import NameSet @@ -337,7 +339,8 @@ mkIface hsc_env maybe_old_iface deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) ifFamInstTcName = ifaceTyConName . ifFamInstTyCon - flattenVectInfo (VectInfo ccVar) = IfaceVectInfo (nameSetToList ccVar) + flattenVectInfo (VectInfo ccVar) = + IfaceVectInfo [Var.varName v | (v, _) <- varEnvElts ccVar] ----------------------------- writeIfaceFile :: DynFlags -> ModLocation -> ModIface -> IO () diff --git a/compiler/iface/TcIface.hi-boot-6 b/compiler/iface/TcIface.hi-boot-6 index 3c8ae73..9153c8c 100644 --- a/compiler/iface/TcIface.hi-boot-6 +++ b/compiler/iface/TcIface.hi-boot-6 @@ -3,6 +3,7 @@ module TcIface where tcIfaceDecl :: GHC.Base.Bool -> IfaceSyn.IfaceDecl -> TcRnTypes.IfL TypeRep.TyThing tcIfaceInst :: IfaceSyn.IfaceInst -> TcRnTypes.IfL InstEnv.Instance tcIfaceRules :: GHC.Base.Bool -> [IfaceSyn.IfaceRule] -> TcRnTypes.IfL [CoreSyn.CoreRule] +tcIfaceVectInfo :: Module.Module -> HscTypes.TypeEnv -> HscTypes.IfaceVectInfo -> TcRnTypes.IfL VectInfo tcIfaceFamInst :: IfaceSyn.IfaceFamInst -> TcRnTypes.IfL FamInstEnv.FamInst diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index a90d069..6f76ae1 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -8,8 +8,8 @@ Type checking of type signatures in interface files \begin{code} module TcIface ( tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, - tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, tcIfaceGlobal, - tcExtCoreBindings + tcIfaceDecl, tcIfaceInst, tcIfaceFamInst, tcIfaceRules, + tcIfaceVectInfo, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" @@ -38,9 +38,9 @@ import DataCon import TysWiredIn import Var ( TyVar ) import qualified Var +import VarEnv import Name import NameEnv -import NameSet import OccName import Module import UniqFM @@ -200,8 +200,8 @@ typecheckIface iface ; rules <- tcIfaceRules ignore_prags (mi_rules iface) -- Vectorisation information - ; let vect_info = VectInfo - (mkNameSet (ifaceVectInfoCCVar (mi_vect_info iface))) + ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env + (mi_vect_info iface) -- Exports ; exports <- ifaceExportNames (mi_exports iface) @@ -578,6 +578,34 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd %************************************************************************ %* * + Vectorisation information +%* * +%************************************************************************ + +\begin{code} +tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo +tcIfaceVectInfo mod typeEnv (IfaceVectInfo names) + = do { ccVars <- mapM ccMapping names + ; return $ VectInfo (mkVarEnv ccVars) + } + where + ccMapping name + = do { ccName <- lookupOrig mod (mkCloOcc (nameOccName name)) + ; let { var = lookup name + ; ccVar = lookup ccName + } + ; return (var, (var, ccVar)) + } + lookup name = case lookupTypeEnv typeEnv name of + Just (AnId var) -> var + Just _ -> + panic "TcIface.tcIfaceVectInfo: wrong TyThing" + Nothing -> + panic "TcIface.tcIfaceVectInfo: unknown name" +\end{code} + +%************************************************************************ +%* * Types %* * %************************************************************************ diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot index ac3e880..51ab255 100644 --- a/compiler/iface/TcIface.lhs-boot +++ b/compiler/iface/TcIface.lhs-boot @@ -6,9 +6,12 @@ import TcRnTypes ( IfL ) import InstEnv ( Instance ) import FamInstEnv ( FamInst ) import CoreSyn ( CoreRule ) +import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) +import Module ( Module ) tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] +tcIfaceVectInfo:: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo tcIfaceInst :: IfaceInst -> IfL Instance tcIfaceFamInst :: IfaceFamInst -> IfL FamInst \end{code} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index bf7d676..956d10d 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -90,7 +90,9 @@ import InstEnv ( InstEnv, Instance ) import FamInstEnv ( FamInstEnv, FamInst ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) +import VarEnv import VarSet +import Var import Id import Type ( TyThing(..) ) @@ -1244,23 +1246,34 @@ 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 +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 +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 { + vectInfoCCVar :: VarEnv (Var, Var) -- (f, f_CC) keyed on f + -- always tidy, even in ModGuts + } -- ModIface version -data IfaceVectInfo = IfaceVectInfo { - ifaceVectInfoCCVar :: [Name] - } +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' + } noVectInfo :: VectInfo -noVectInfo = VectInfo emptyNameSet +noVectInfo = VectInfo emptyVarEnv plusVectInfo :: VectInfo -> VectInfo -> VectInfo plusVectInfo vi1 vi2 = - VectInfo (vectInfoCCVar vi1 `unionNameSets` vectInfoCCVar vi2) + VectInfo (vectInfoCCVar vi1 `plusVarEnv` vectInfoCCVar vi2) noIfaceVectInfo :: IfaceVectInfo noIfaceVectInfo = IfaceVectInfo [] diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 6b89b33..7405d14 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, filterNameSet ) +import NameSet ( NameSet, elemNameSet ) import IfaceEnv ( allocateGlobalBinder ) import NameEnv ( filterNameEnv, mapNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) @@ -287,12 +287,6 @@ 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 @@ -314,7 +308,7 @@ tidyProgram hsc_env md_fam_insts = fam_insts, md_exports = exports, md_modBreaks = modBreaks, - md_vect_info = tidy_vect_info + md_vect_info = vect_info -- is already tidy }) } @@ -323,11 +317,6 @@ 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