From: Manuel M T Chakravarty Date: Fri, 3 Jun 2011 00:42:48 +0000 (+1000) Subject: Propagate scalar variables and tycons for vectorisation through 'HscTypes.VectInfo'. X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=2c8aabcad1d2f2c469cb8a10afa7b66beeaedd45 Propagate scalar variables and tycons for vectorisation through 'HscTypes.VectInfo'. --- diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index c80628b..502eefa 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1508,14 +1508,18 @@ instance Binary name => Binary (AnnTarget name) where return (ModuleTarget a) instance Binary IfaceVectInfo where - put_ bh (IfaceVectInfo a1 a2 a3) = do + put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do put_ bh a1 put_ bh a2 put_ bh a3 + put_ bh a4 + put_ bh a5 get bh = do a1 <- get bh a2 <- get bh a3 <- get bh - return (IfaceVectInfo a1 a2 a3) + a4 <- get bh + a5 <- get bh + return (IfaceVectInfo a1 a2 a3 a4 a5) diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index e92a160..97acc52 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -729,14 +729,18 @@ pprFixities fixes = ptext (sLit "fixities") <+> pprWithCommas pprFix fixes pprFix (occ,fix) = ppr fix <+> ppr occ pprVectInfo :: IfaceVectInfo -> SDoc -pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars - , ifaceVectInfoTyCon = tycons - , ifaceVectInfoTyConReuse = tyconsReuse +pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + , ifaceVectInfoScalarVars = scalarVars + , ifaceVectInfoScalarTyCons = scalarTyCons }) = vcat [ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars) , ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons) , ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse) + , ptext (sLit "scalar variables:") <+> hsep (map ppr scalarVars) + , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons) ] instance Outputable Warnings where diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs index 5c58a80..0bce56b 100644 --- a/compiler/iface/MkIface.lhs +++ b/compiler/iface/MkIface.lhs @@ -7,23 +7,23 @@ module MkIface ( mkUsedNames, mkDependencies, - mkIface, -- Build a ModIface from a ModGuts, - -- including computing version information + mkIface, -- Build a ModIface from a ModGuts, + -- including computing version information mkIfaceTc, - writeIfaceFile, -- Write the interface file + writeIfaceFile, -- Write the interface file - checkOldIface, -- See if recompilation is required, by - -- comparing version information + checkOldIface, -- See if recompilation is required, by + -- comparing version information tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where \end{code} - ----------------------------------------------- - Recompilation checking - ----------------------------------------------- + ----------------------------------------------- + Recompilation checking + ----------------------------------------------- A complete description of how recompilation checking works can be found in the wiki commentary: @@ -72,6 +72,7 @@ import HscTypes import Finder import DynFlags import VarEnv +import VarSet import Var import Name import RdrName @@ -325,18 +326,17 @@ mkIface_ hsc_env maybe_old_fingerprint ifFamInstTcName = ifaceTyConName . ifFamInstTyCon - flattenVectInfo (VectInfo { vectInfoVar = vVar - , vectInfoTyCon = vTyCon + flattenVectInfo (VectInfo { vectInfoVar = vVar + , vectInfoTyCon = vTyCon + , vectInfoScalarVars = vScalarVars + , vectInfoScalarTyCons = vScalarTyCons }) = - IfaceVectInfo { - ifaceVectInfoVar = [ Var.varName v - | (v, _) <- varEnvElts vVar], - ifaceVectInfoTyCon = [ tyConName t - | (t, t_v) <- nameEnvElts vTyCon - , t /= t_v], - ifaceVectInfoTyConReuse = [ tyConName t - | (t, t_v) <- nameEnvElts vTyCon - , t == t_v] + IfaceVectInfo + { ifaceVectInfoVar = [Var.varName v | (v, _ ) <- varEnvElts vVar] + , ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v] + , ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v] + , ifaceVectInfoScalarVars = [Var.varName v | v <- varSetElems vScalarVars] + , ifaceVectInfoScalarTyCons = nameSetToList vScalarTyCons } ----------------------------- diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index 7ac95b1..5bfb406 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -39,14 +39,16 @@ import Class import TyCon import DataCon import TysWiredIn -import TysPrim ( anyTyConOfKind ) -import BasicTypes ( Arity, nonRuleLoopBreaker ) +import TysPrim ( anyTyConOfKind ) +import BasicTypes ( Arity, nonRuleLoopBreaker ) import qualified Var import VarEnv +import VarSet import Name import NameEnv -import OccurAnal ( occurAnalyseExpr ) -import Demand ( isBottomingSig ) +import NameSet +import OccurAnal ( occurAnalyseExpr ) +import Demand ( isBottomingSig ) import Module import UniqFM import UniqSupply @@ -689,28 +691,32 @@ tcIfaceAnnTarget (ModuleTarget mod) = do %************************************************************************ -%* * - Vectorisation information -%* * +%* * + Vectorisation information +%* * %************************************************************************ \begin{code} tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo tcIfaceVectInfo mod typeEnv (IfaceVectInfo - { ifaceVectInfoVar = vars - , ifaceVectInfoTyCon = tycons - , ifaceVectInfoTyConReuse = tyconsReuse + { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + , ifaceVectInfoScalarVars = scalarVars + , ifaceVectInfoScalarTyCons = scalarTyCons }) = do { vVars <- mapM vectVarMapping vars ; tyConRes1 <- mapM vectTyConMapping tycons ; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2) ; return $ VectInfo - { vectInfoVar = mkVarEnv vVars - , vectInfoTyCon = mkNameEnv vTyCons - , vectInfoDataCon = mkNameEnv (concat vDataCons) - , vectInfoPADFun = mkNameEnv vPAs - , vectInfoIso = mkNameEnv vIsos + { vectInfoVar = mkVarEnv vVars + , vectInfoTyCon = mkNameEnv vTyCons + , vectInfoDataCon = mkNameEnv (concat vDataCons) + , vectInfoPADFun = mkNameEnv vPAs + , vectInfoIso = mkNameEnv vIsos + , vectInfoScalarVars = mkVarSet (map lookupVar scalarVars) + , vectInfoScalarTyCons = mkNameSet scalarTyCons } } where @@ -778,9 +784,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo \end{code} %************************************************************************ -%* * - Types -%* * +%* * + Types +%* * %************************************************************************ \begin{code} diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 22aa3f4..fdc268c 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -100,7 +100,7 @@ module HscTypes ( #include "HsVersions.h" #ifdef GHCI -import ByteCodeAsm ( CompiledByteCode ) +import ByteCodeAsm ( CompiledByteCode ) import {-# SOURCE #-} InteractiveEval ( Resume ) #endif @@ -108,16 +108,17 @@ import HsSyn import RdrName import Name import NameEnv -import NameSet +import NameSet import Module -import InstEnv ( InstEnv, Instance ) -import FamInstEnv ( FamInstEnv, FamInst ) -import Rules ( RuleBase ) -import CoreSyn ( CoreBind ) +import InstEnv ( InstEnv, Instance ) +import FamInstEnv ( FamInstEnv, FamInst ) +import Rules ( RuleBase ) +import CoreSyn ( CoreBind ) import VarEnv +import VarSet import Var import Id -import Type +import Type import Annotations import Class ( Class, classAllSelIds, classATs, classTyCon ) @@ -1712,9 +1713,9 @@ isHpcUsed (NoHpcInfo { hpcUsed = used }) = used \end{code} %************************************************************************ -%* * +%* * \subsection{Vectorisation Support} -%* * +%* * %************************************************************************ The following information is generated and consumed by the vectorisation @@ -1727,49 +1728,58 @@ vectorisation, we need to know `f_v', whose `Var' we cannot lookup based on just the OccName easily in a Core pass. \begin{code} --- | Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'. +-- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also +-- documentation at 'Vectorise.Env.GlobalEnv'. 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@ - vectInfoPADFun :: NameEnv (TyCon , Var), -- ^ @(T_v, paT)@ keyed on @T_v@ - vectInfoIso :: NameEnv (TyCon , Var) -- ^ @(T, isoT)@ keyed on @T@ + = 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@ + , vectInfoPADFun :: NameEnv (TyCon , Var) -- ^ @(T_v, paT)@ keyed on @T_v@ + , vectInfoIso :: NameEnv (TyCon , Var) -- ^ @(T, isoT)@ keyed on @T@ + , vectInfoScalarVars :: VarSet -- ^ set of purely scalar variables + , vectInfoScalarTyCons :: NameSet -- ^ set of scalar type constructors } --- | Vectorisation information for 'ModIface': a slightly less low-level view +-- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated +-- across module boundaries. +-- data IfaceVectInfo - = IfaceVectInfo { - ifaceVectInfoVar :: [Name], - -- ^ All variables in here have a vectorised variant - ifaceVectInfoTyCon :: [Name], - -- ^ All 'TyCon's in here have a vectorised variant; - -- the name of the vectorised variant and those of its - -- data constructors are determined by 'OccName.mkVectTyConOcc' - -- and 'OccName.mkVectDataConOcc'; the names of - -- the isomorphisms are determined by 'OccName.mkVectIsoOcc' - ifaceVectInfoTyConReuse :: [Name] - -- ^ The vectorised form of all the 'TyCon's in here coincides with - -- the unconverted form; the name of the isomorphisms is determined - -- by 'OccName.mkVectIsoOcc' + = IfaceVectInfo + { ifaceVectInfoVar :: [Name] -- ^ All variables in here have a vectorised variant + , ifaceVectInfoTyCon :: [Name] -- ^ All 'TyCon's in here have a vectorised variant; + -- the name of the vectorised variant and those of its + -- data constructors are determined by + -- 'OccName.mkVectTyConOcc' and + -- 'OccName.mkVectDataConOcc'; the names of the + -- isomorphisms are determined by 'OccName.mkVectIsoOcc' + , ifaceVectInfoTyConReuse :: [Name] -- ^ The vectorised form of all the 'TyCon's in here + -- coincides with the unconverted form; the name of the + -- isomorphisms is determined by 'OccName.mkVectIsoOcc' + , ifaceVectInfoScalarVars :: [Name] -- iface version of 'vectInfoScalarVar' + , ifaceVectInfoScalarTyCons :: [Name] -- iface version of 'vectInfoScalarTyCon' } noVectInfo :: VectInfo -noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv +noVectInfo + = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyVarSet + emptyNameSet plusVectInfo :: VectInfo -> VectInfo -> VectInfo plusVectInfo vi1 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) + 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) + (vectInfoScalarVars vi1 `unionVarSet` vectInfoScalarVars vi2) + (vectInfoScalarTyCons vi1 `unionNameSets` vectInfoScalarTyCons vi2) concatVectInfo :: [VectInfo] -> VectInfo concatVectInfo = foldr plusVectInfo noVectInfo noIfaceVectInfo :: IfaceVectInfo -noIfaceVectInfo = IfaceVectInfo [] [] [] +noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] \end{code} %************************************************************************ diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index b4296cb..b3f1a06 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -487,12 +487,16 @@ tidyInstances tidy_dfun ispecs \begin{code} tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo -tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars - , vectInfoPADFun = pas - , vectInfoIso = isos }) - = info { vectInfoVar = tidy_vars - , vectInfoPADFun = tidy_pas - , vectInfoIso = tidy_isos } +tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars + , vectInfoPADFun = pas + , vectInfoIso = isos + , vectInfoScalarVars = scalarVars + }) + = info { vectInfoVar = tidy_vars + , vectInfoPADFun = tidy_pas + , vectInfoIso = tidy_isos + , vectInfoScalarVars = tidy_scalarVars + } where tidy_vars = mkVarEnv $ map tidy_var_mapping @@ -504,6 +508,10 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars tidy_var_mapping (from, to) = (from', (from', lookup_var to)) where from' = lookup_var from tidy_snd_var (x, var) = (x, lookup_var var) + + tidy_scalarVars = mkVarSet + $ map lookup_var + $ varSetElems scalarVars lookup_var var = lookupWithDefaultVarEnv var_env var var \end{code} diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 5014fd6..fe7be1f 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -1,24 +1,24 @@ module Vectorise.Env ( - Scope(..), - - -- * Local Environments - LocalEnv(..), - emptyLocalEnv, - - -- * Global Environments - GlobalEnv(..), - initGlobalEnv, - extendImportedVarsEnv, - extendScalars, - setFamEnv, - extendFamEnv, - extendTyConsEnv, - extendDataConsEnv, - extendPAFunsEnv, - setPRFunsEnv, - setBoxedTyConsEnv, - updVectInfo + Scope(..), + + -- * Local Environments + LocalEnv(..), + emptyLocalEnv, + + -- * Global Environments + GlobalEnv(..), + initGlobalEnv, + extendImportedVarsEnv, + extendScalars, + setFamEnv, + extendFamEnv, + extendTyConsEnv, + extendDataConsEnv, + extendPAFunsEnv, + setPRFunsEnv, + setBoxedTyConsEnv, + modVectInfo ) where import HscTypes @@ -31,6 +31,7 @@ import DataCon import VarEnv import VarSet import Var +import NameSet import Name import NameEnv import FastString @@ -38,8 +39,8 @@ import FastString -- | Indicates what scope something (a variable) is in. data Scope a b - = Global a - | Local b + = Global a + | Local b -- LocalEnv ------------------------------------------------------------------- @@ -71,61 +72,68 @@ emptyLocalEnv = LocalEnv { -- GlobalEnv ------------------------------------------------------------------ --- | The global environment. --- These are things the exist at top-level. + +-- |The global environment: entities that exist at top-level. +-- data GlobalEnv - = GlobalEnv { - -- | Mapping from global variables to their vectorised versions — aka the /vectorisation - -- map/. - global_vars :: VarEnv Var - - -- | Mapping from global variables that have a vectorisation declaration to the right-hand - -- side of that declaration and its type. This mapping only applies to non-scalar - -- vectorisation declarations. All variables with a scalar vectorisation declaration are - -- mentioned in 'global_scalars'. + = GlobalEnv + -- |Mapping from global variables to their vectorised versions — aka the /vectorisation + -- map/. + { global_vars :: VarEnv Var + + -- |Mapping from global variables that have a vectorisation declaration to the right-hand + -- side of that declaration and its type. This mapping only applies to non-scalar + -- vectorisation declarations. All variables with a scalar vectorisation declaration are + -- mentioned in 'global_scalars_vars'. , global_vect_decls :: VarEnv (Type, CoreExpr) - -- | Purely scalar variables. Code which mentions only these variables doesn't have to be - -- lifted. This includes variables from the current module that have a scalar - -- vectorisation declaration and those that the vectoriser determines to be scalar. - , global_scalars :: VarSet + -- |Purely scalar variables. Code which mentions only these variables doesn't have to be + -- lifted. This includes variables from the current module that have a scalar + -- vectorisation declaration and those that the vectoriser determines to be scalar. + , global_scalar_vars :: VarSet + + -- |Type constructors whose values can only contain scalar data. Scalar code may only + -- operate on such data. + , global_scalar_tycons :: NameSet - -- | Exported variables which have a vectorised version. - , global_exported_vars :: VarEnv (Var, Var) + -- |Exported variables which have a vectorised version. + , global_exported_vars :: VarEnv (Var, Var) - -- | Mapping from TyCons to their vectorised versions. - -- TyCons which do not have to be vectorised are mapped to themselves. - , global_tycons :: NameEnv TyCon + -- |Mapping from TyCons to their vectorised versions. + -- TyCons which do not have to be vectorised are mapped to themselves. + , global_tycons :: NameEnv TyCon - -- | Mapping from DataCons to their vectorised versions. + -- |Mapping from DataCons to their vectorised versions. , global_datacons :: NameEnv DataCon - -- | Mapping from TyCons to their PA dfuns. + -- |Mapping from TyCons to their PA dfuns. , global_pa_funs :: NameEnv Var - -- | Mapping from TyCons to their PR dfuns. - , global_pr_funs :: NameEnv Var + -- |Mapping from TyCons to their PR dfuns. + , global_pr_funs :: NameEnv Var - -- | Mapping from unboxed TyCons to their boxed versions. - , global_boxed_tycons :: NameEnv TyCon + -- |Mapping from unboxed TyCons to their boxed versions. + , global_boxed_tycons :: NameEnv TyCon - -- | External package inst-env & home-package inst-env for class instances. - , global_inst_env :: (InstEnv, InstEnv) + -- |External package inst-env & home-package inst-env for class instances. + , global_inst_env :: (InstEnv, InstEnv) - -- | External package inst-env & home-package inst-env for family instances. - , global_fam_inst_env :: FamInstEnvs + -- |External package inst-env & home-package inst-env for family instances. + , global_fam_inst_env :: FamInstEnvs - -- | Hoisted bindings. - , global_bindings :: [(Var, CoreExpr)] + -- |Hoisted bindings. + , global_bindings :: [(Var, CoreExpr)] } --- | Create an initial global environment +-- |Create an initial global environment. +-- initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv initGlobalEnv info vectDecls instEnvs famInstEnvs = GlobalEnv { global_vars = mapVarEnv snd $ vectInfoVar info , global_vect_decls = mkVarEnv vects - , global_scalars = mkVarSet scalars + , global_scalar_vars = vectInfoScalarVars info `extendVarSetList` scalars + , global_scalar_tycons = vectInfoScalarTyCons info , global_exported_vars = emptyVarEnv , global_tycons = mapNameEnv snd $ vectInfoTyCon info , global_datacons = mapNameEnv snd $ vectInfoDataCon info @@ -142,71 +150,80 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs -- Operators on Global Environments ------------------------------------------- --- | Extend the list of global variables in an environment. + +-- |Extend the list of global variables in an environment. +-- extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv extendImportedVarsEnv ps genv - = genv { global_vars = extendVarEnvList (global_vars genv) ps } + = genv { global_vars = extendVarEnvList (global_vars genv) ps } --- | Extend the set of scalar variables in an environment. +-- |Extend the set of scalar variables in an environment. +-- extendScalars :: [Var] -> GlobalEnv -> GlobalEnv extendScalars vs genv - = genv { global_scalars = extendVarSetList (global_scalars genv) vs } + = genv { global_scalar_vars = extendVarSetList (global_scalar_vars genv) vs } --- | Set the list of type family instances in an environment. +-- |Set the list of type family instances in an environment. +-- setFamEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv setFamEnv l_fam_inst genv = genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) } where (g_fam_inst, _) = global_fam_inst_env genv +-- |Extend the list of type family instances. +-- extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv extendFamEnv new genv = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) } where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv - --- | Extend the list of type constructors in an environment. +-- |Extend the list of type constructors in an environment. +-- extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv extendTyConsEnv ps genv = genv { global_tycons = extendNameEnvList (global_tycons genv) ps } - --- | Extend the list of data constructors in an environment. +-- |Extend the list of data constructors in an environment. +-- extendDataConsEnv :: [(Name, DataCon)] -> GlobalEnv -> GlobalEnv extendDataConsEnv ps genv = genv { global_datacons = extendNameEnvList (global_datacons genv) ps } - --- | Extend the list of PA functions in an environment. +-- |Extend the list of PA functions in an environment. +-- extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv extendPAFunsEnv ps genv = genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps } - --- | Set the list of PR functions in an environment. +-- |Set the list of PR functions in an environment. +-- setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps } - --- | Set the list of boxed type constructor in an environment. +-- |Set the list of boxed type constructor in an environment. +-- setBoxedTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv setBoxedTyConsEnv ps genv = genv { global_boxed_tycons = mkNameEnv ps } - --- | TODO: What is this for? -updVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo -updVectInfo env tyenv info +-- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files). +-- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'. The outgoing one contains only the +-- definitions for the currently compiled module. +-- +modVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo +modVectInfo env tyenv info = info - { vectInfoVar = global_exported_vars env - , vectInfoTyCon = mk_env typeEnvTyCons global_tycons - , vectInfoDataCon = mk_env typeEnvDataCons global_datacons - , vectInfoPADFun = mk_env typeEnvTyCons global_pa_funs + { vectInfoVar = global_exported_vars env + , vectInfoTyCon = mk_env typeEnvTyCons global_tycons + , vectInfoDataCon = mk_env typeEnvDataCons global_datacons + , vectInfoPADFun = mk_env typeEnvTyCons global_pa_funs + , vectInfoScalarVars = global_scalar_vars env `minusVarSet` vectInfoScalarVars info + , vectInfoScalarTyCons = global_scalar_tycons env `minusNameSet` vectInfoScalarTyCons info } where mk_env from_tyenv from_env - = mkNameEnv [(name, (from,to)) - | from <- from_tyenv tyenv - , let name = getName from - , Just to <- [lookupNameEnv (from_env env) name]] - + = mkNameEnv [(name, (from,to)) + | from <- from_tyenv tyenv + , let name = getName from + , Just to <- [lookupNameEnv (from_env env) name]] diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 5fcd2ac..e2933cd 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -1,27 +1,26 @@ module Vectorise.Monad ( - module Vectorise.Monad.Base, - module Vectorise.Monad.Naming, - module Vectorise.Monad.Local, - module Vectorise.Monad.Global, - module Vectorise.Monad.InstEnv, - initV, - - -- * Builtins - liftBuiltinDs, - builtin, - builtins, - - -- * Variables - lookupVar, - maybeCantVectoriseVarM, - dumpVar, - addGlobalScalar, - deleteGlobalScalar, + module Vectorise.Monad.Base, + module Vectorise.Monad.Naming, + module Vectorise.Monad.Local, + module Vectorise.Monad.Global, + module Vectorise.Monad.InstEnv, + initV, + + -- * Builtins + liftBuiltinDs, + builtin, + builtins, + + -- * Variables + lookupVar, + maybeCantVectoriseVarM, + dumpVar, + addGlobalScalar, - -- * Primitives - lookupPrimPArray, - lookupPrimMethod + -- * Primitives + lookupPrimPArray, + lookupPrimMethod ) where import Vectorise.Monad.Base @@ -98,7 +97,7 @@ initV hsc_env guts info thing_inside No -> return Nothing } } - new_info genv = updVectInfo genv (mg_types guts) info + new_info genv = modVectInfo genv (mg_types guts) info selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq" @@ -120,7 +119,7 @@ builtins f = VM $ \bi genv lenv -> return (Yes genv lenv (`f` bi)) -- Var ------------------------------------------------------------------------ -- | Lookup the vectorised and\/or lifted versions of this variable. --- If it's in the global environment we get the vectorised version. +-- If it's in the global environment we get the vectorised version. -- If it's in the local environment we get both the vectorised and lifted version. lookupVar :: Var -> VM (Scope Var (Var, Var)) lookupVar v @@ -140,29 +139,24 @@ maybeCantVectoriseVarM v p dumpVar :: Var -> a dumpVar var - | Just _ <- isClassOpId_maybe var - = cantVectorise "ClassOpId not vectorised:" (ppr var) + | Just _ <- isClassOpId_maybe var + = cantVectorise "ClassOpId not vectorised:" (ppr var) - | otherwise - = cantVectorise "Variable not vectorised:" (ppr var) + | otherwise + = cantVectorise "Variable not vectorised:" (ppr var) --- local scalars -------------------------------------------------------------- +-- Global scalars -------------------------------------------------------------- addGlobalScalar :: Var -> VM () addGlobalScalar var = do { traceVt "addGlobalScalar" (ppr var) - ; updGEnv $ \env -> env{global_scalars = extendVarSet (global_scalars env) var} - } - -deleteGlobalScalar :: Var -> VM () -deleteGlobalScalar var - = do { traceVt "deleteGlobalScalar" (ppr var) - ; updGEnv $ \env -> env{global_scalars = delVarSet (global_scalars env) var} - } + ; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var} + } -- Primitives ----------------------------------------------------------------- + lookupPrimPArray :: TyCon -> VM (Maybe TyCon) lookupPrimPArray = liftBuiltinDs . primPArray diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs index ae68ffb..632845f 100644 --- a/compiler/vectorise/Vectorise/Monad/Global.hs +++ b/compiler/vectorise/Vectorise/Monad/Global.hs @@ -73,19 +73,24 @@ defGlobalVar v v' = updGEnv $ \env -> -- Vectorisation declarations ------------------------------------------------- --- | Check whether a variable has a (non-scalar) vectorisation declaration. + +-- |Check whether a variable has a (non-scalar) vectorisation declaration. +-- lookupVectDecl :: Var -> VM (Maybe (Type, CoreExpr)) lookupVectDecl var = readGEnv $ \env -> lookupVarEnv (global_vect_decls env) var -- Scalars -------------------------------------------------------------------- --- | Get the set of global scalar variables. + +-- |Get the set of global scalar variables. +-- globalScalars :: VM VarSet -globalScalars = readGEnv global_scalars +globalScalars = readGEnv global_scalar_vars --- | Check whether a given variable is in the set of global scalar variables. +-- |Check whether a given variable is in the set of global scalar variables. +-- isGlobalScalar :: Var -> VM Bool -isGlobalScalar var = readGEnv $ \env -> elemVarSet var (global_scalars env) +isGlobalScalar var = readGEnv $ \env -> elemVarSet var (global_scalar_vars env) -- TyCons ---------------------------------------------------------------------