Commit b77da25e authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

Rewrote vectorisation avoidance (based on the HS paper)

* Vectorisation avoidance is now the default
* Types and values from unvectorised modules are permitted in scalar code
* Simplified the VECTORISE pragmas (see http://hackage.haskell.org/trac/ghc/wiki/DataParallel/VectPragma for the spec)
* Vectorisation information is now included in the annotated Core AST
parent 2a7217e3
......@@ -328,12 +328,11 @@ breaker, which is perfectly inlinable.
vectsFreeVars :: [CoreVect] -> VarSet
vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
where
vectFreeVars (Vect _ Nothing) = noFVs
vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs
vectFreeVars (VectClass _) = noFVs
vectFreeVars (VectInst _) = noFVs
vectFreeVars (Vect _ rhs) = expr_fvs rhs isLocalId emptyVarSet
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs
vectFreeVars (VectClass _) = noFVs
vectFreeVars (VectInst _) = noFVs
-- this function is only concerned with values, not types
\end{code}
......
......@@ -749,12 +749,11 @@ substVects subst = map (substVect subst)
------------------
substVect :: Subst -> CoreVect -> CoreVect
substVect _subst (Vect v Nothing) = Vect v Nothing
substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs))
substVect _subst vd@(NoVect _) = vd
substVect _subst vd@(VectType _ _ _) = vd
substVect _subst vd@(VectClass _) = vd
substVect _subst vd@(VectInst _) = vd
substVect subst (Vect v rhs) = Vect v (simpleOptExprWith subst rhs)
substVect _subst vd@(NoVect _) = vd
substVect _subst vd@(VectType _ _ _) = vd
substVect _subst vd@(VectClass _) = vd
substVect _subst vd@(VectInst _) = vd
------------------
substVarSet :: Subst -> VarSet -> VarSet
......
......@@ -592,11 +592,11 @@ Representation of desugared vectorisation declarations that are fed to the vecto
'ModGuts').
\begin{code}
data CoreVect = Vect Id (Maybe CoreExpr)
data CoreVect = Vect Id CoreExpr
| NoVect Id
| VectType Bool TyCon (Maybe TyCon)
| VectClass TyCon -- class tycon
| VectInst Id -- instance dfun (always SCALAR)
| VectInst Id -- instance dfun (always SCALAR) !!!FIXME: should be superfluous now
\end{code}
......
......@@ -494,8 +494,7 @@ instance Outputable id => Outputable (Tickish id) where
\begin{code}
instance Outputable CoreVect where
ppr (Vect var Nothing) = ptext (sLit "VECTORISE SCALAR") <+> ppr var
ppr (Vect var (Just e)) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
ppr (Vect var e) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
4 (pprCoreExpr e)
ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var
ppr (VectType False var Nothing) = ptext (sLit "VECTORISE type") <+> ppr var
......
......@@ -432,7 +432,7 @@ the rule is precisly to optimise them:
dsVect :: LVectDecl Id -> DsM CoreVect
dsVect (L loc (HsVect (L _ v) rhs))
= putSrcSpanDs loc $
do { rhs' <- fmapMaybeM dsLExpr rhs
do { rhs' <- dsLExpr rhs
; return $ Vect v rhs'
}
dsVect (L _loc (HsNoVect (L _ v)))
......
......@@ -1111,7 +1111,7 @@ type LVectDecl name = Located (VectDecl name)
data VectDecl name
= HsVect
(Located name)
(Maybe (LHsExpr name)) -- 'Nothing' => SCALAR declaration
(LHsExpr name)
| HsNoVect
(Located name)
| HsVectTypeIn -- pre type-checking
......@@ -1126,9 +1126,9 @@ data VectDecl name
(Located name)
| HsVectClassOut -- post type-checking
Class
| HsVectInstIn -- pre type-checking (always SCALAR)
| HsVectInstIn -- pre type-checking (always SCALAR) !!!FIXME: should be superfluous now
(LHsType name)
| HsVectInstOut -- post type-checking (always SCALAR)
| HsVectInstOut -- post type-checking (always SCALAR) !!!FIXME: should be superfluous now
ClsInst
deriving (Data, Typeable)
......@@ -1148,9 +1148,7 @@ lvectInstDecl (L _ (HsVectInstOut _)) = True
lvectInstDecl _ = False
instance OutputableBndr name => Outputable (VectDecl name) where
ppr (HsVect v Nothing)
= sep [text "{-# VECTORISE SCALAR" <+> ppr v <+> text "#-}" ]
ppr (HsVect v (Just rhs))
ppr (HsVect v rhs)
= sep [text "{-# VECTORISE" <+> ppr v,
nest 4 $
pprExpr (unLoc rhs) <+> text "#-}" ]
......
......@@ -750,18 +750,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
, ifaceVectInfoScalarVars = scalarVars
, ifaceVectInfoScalarTyCons = scalarTyCons
pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars
, ifaceVectInfoTyCon = tycons
, ifaceVectInfoTyConReuse = tyconsReuse
, ifaceVectInfoParallelVars = parallelVars
, ifaceVectInfoParallelTyCons = parallelTyCons
}) =
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)
, ptext (sLit "parallel variables:") <+> hsep (map ppr parallelVars)
, ptext (sLit "parallel tycons:") <+> hsep (map ppr parallelTyCons)
]
pprTrustInfo :: IfaceTrustInfo -> SDoc
......
......@@ -373,17 +373,17 @@ mkIface_ hsc_env maybe_old_fingerprint
ifFamInstTcName = ifFamInstFam
flattenVectInfo (VectInfo { vectInfoVar = vVar
, vectInfoTyCon = vTyCon
, vectInfoScalarVars = vScalarVars
, vectInfoScalarTyCons = vScalarTyCons
flattenVectInfo (VectInfo { vectInfoVar = vVar
, vectInfoTyCon = vTyCon
, vectInfoParallelVars = vParallelVars
, vectInfoParallelTyCons = vParallelTyCons
}) =
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
{ 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]
, ifaceVectInfoParallelVars = [Var.varName v | v <- varSetElems vParallelVars]
, ifaceVectInfoParallelTyCons = nameSetToList vParallelTyCons
}
-----------------------------
......
......@@ -748,25 +748,25 @@ tcIfaceAnnTarget (ModuleTarget mod) = do
--
tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
tcIfaceVectInfo mod typeEnv (IfaceVectInfo
{ ifaceVectInfoVar = vars
, ifaceVectInfoTyCon = tycons
, ifaceVectInfoTyConReuse = tyconsReuse
, ifaceVectInfoScalarVars = scalarVars
, ifaceVectInfoScalarTyCons = scalarTyCons
{ ifaceVectInfoVar = vars
, ifaceVectInfoTyCon = tycons
, ifaceVectInfoTyConReuse = tyconsReuse
, ifaceVectInfoParallelVars = parallelVars
, ifaceVectInfoParallelTyCons = parallelTyCons
})
= do { let scalarTyConsSet = mkNameSet scalarTyCons
; vVars <- mapM vectVarMapping vars
= do { let parallelTyConsSet = mkNameSet parallelTyCons
; vVars <- mapM vectVarMapping vars
; let varsSet = mkVarSet (map fst vVars)
; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
; vScalarVars <- mapM vectVar scalarVars
; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
; vParallelVars <- mapM vectVar parallelVars
; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
; return $ VectInfo
{ vectInfoVar = mkVarEnv vVars `extendVarEnvList` concat vScSels
, vectInfoTyCon = mkNameEnv vTyCons
, vectInfoDataCon = mkNameEnv (concat vDataCons)
, vectInfoScalarVars = mkVarSet vScalarVars
, vectInfoScalarTyCons = scalarTyConsSet
{ vectInfoVar = mkVarEnv vVars `extendVarEnvList` concat vScSels
, vectInfoTyCon = mkNameEnv vTyCons
, vectInfoDataCon = mkNameEnv (concat vDataCons)
, vectInfoParallelVars = mkVarSet vParallelVars
, vectInfoParallelTyCons = parallelTyConsSet
}
}
where
......
......@@ -1968,11 +1968,11 @@ on just the OccName easily in a Core pass.
--
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@
, vectInfoScalarVars :: VarSet -- ^ set of purely scalar variables
, vectInfoScalarTyCons :: NameSet -- ^ set of scalar type constructors
{ 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@
, vectInfoParallelVars :: VarSet -- ^ set of parallel variables
, vectInfoParallelTyCons :: NameSet -- ^ set of parallel type constructors
}
-- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated
......@@ -1986,18 +1986,18 @@ data VectInfo
--
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'
, ifaceVectInfoScalarVars :: [Name] -- iface version of 'vectInfoScalarVar'
, ifaceVectInfoScalarTyCons :: [Name] -- iface version of 'vectInfoScalarTyCon'
{ 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'
, ifaceVectInfoParallelVars :: [Name] -- iface version of 'vectInfoParallelVar'
, ifaceVectInfoParallelTyCons :: [Name] -- iface version of 'vectInfoParallelTyCon'
}
noVectInfo :: VectInfo
......@@ -2006,11 +2006,11 @@ noVectInfo
plusVectInfo :: VectInfo -> VectInfo -> VectInfo
plusVectInfo vi1 vi2 =
VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2)
(vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2)
(vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2)
(vectInfoScalarVars vi1 `unionVarSet` vectInfoScalarVars vi2)
(vectInfoScalarTyCons vi1 `unionNameSets` vectInfoScalarTyCons vi2)
VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2)
(vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2)
(vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2)
(vectInfoParallelVars vi1 `unionVarSet` vectInfoParallelVars vi2)
(vectInfoParallelTyCons vi1 `unionNameSets` vectInfoParallelTyCons vi2)
concatVectInfo :: [VectInfo] -> VectInfo
concatVectInfo = foldr plusVectInfo noVectInfo
......@@ -2024,11 +2024,11 @@ isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5)
instance Outputable VectInfo where
ppr info = vcat
[ ptext (sLit "variables :") <+> ppr (vectInfoVar info)
, ptext (sLit "tycons :") <+> ppr (vectInfoTyCon info)
, ptext (sLit "datacons :") <+> ppr (vectInfoDataCon info)
, ptext (sLit "scalar vars :") <+> ppr (vectInfoScalarVars info)
, ptext (sLit "scalar tycons :") <+> ppr (vectInfoScalarTyCons info)
[ ptext (sLit "variables :") <+> ppr (vectInfoVar info)
, ptext (sLit "tycons :") <+> ppr (vectInfoTyCon info)
, ptext (sLit "datacons :") <+> ppr (vectInfoDataCon info)
, ptext (sLit "parallel vars :") <+> ppr (vectInfoParallelVars info)
, ptext (sLit "parallel tycons :") <+> ppr (vectInfoParallelTyCons info)
]
\end{code}
......
......@@ -542,10 +542,10 @@ tidyInstances tidy_dfun ispecs
\begin{code}
tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo
tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
, vectInfoScalarVars = scalarVars
, vectInfoParallelVars = parallelVars
})
= info { vectInfoVar = tidy_vars
, vectInfoScalarVars = tidy_scalarVars
, vectInfoParallelVars = tidy_parallelVars
}
where
-- we only export mappings whose domain and co-domain is exported (otherwise, the iface is
......@@ -559,9 +559,9 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars
, isDataConWorkId var || not (isImplicitId var)
]
tidy_scalarVars = mkVarSet [ lookup_var var
| var <- varSetElems scalarVars
, isGlobalId var || isExportedId var]
tidy_parallelVars = mkVarSet [ lookup_var var
| var <- varSetElems parallelVars
, isGlobalId var || isExportedId var]
lookup_var var = lookupWithDefaultVarEnv var_env var var
\end{code}
......
......@@ -577,8 +577,7 @@ topdecl :: { OrdList (LHsDecl RdrName) }
| '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# WARNING' warnings '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 }
| '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) }
| '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) }
| '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 $4) }
| '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) }
| '{-# VECTORISE' 'type' gtycon '#-}'
{ unitOL $ LL $
......@@ -593,8 +592,6 @@ topdecl :: { OrdList (LHsDecl RdrName) }
{ unitOL $ LL $
VectD (HsVectTypeIn True $3 (Just $5)) }
| '{-# VECTORISE' 'class' gtycon '#-}' { unitOL $ LL $ VectD (HsVectClassIn $3) }
| '{-# VECTORISE_SCALAR' 'instance' type '#-}'
{ unitOL $ LL $ VectD (HsVectInstIn $3) }
| annotation { unitOL $1 }
| decl { unLoc $1 }
......
......@@ -723,18 +723,14 @@ badRuleLhsErr name lhs bad_e
\begin{code}
rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
rnHsVectDecl (HsVect var Nothing)
= do { var' <- lookupLocatedOccRn var
; return (HsVect var' Nothing, unitFV (unLoc var'))
}
-- FIXME: For the moment, the right-hand side is restricted to be a variable as we cannot properly
-- typecheck a complex right-hand side without invoking 'vectType' from the vectoriser.
rnHsVectDecl (HsVect var (Just rhs@(L _ (HsVar _))))
rnHsVectDecl (HsVect var rhs@(L _ (HsVar _)))
= do { var' <- lookupLocatedOccRn var
; (rhs', fv_rhs) <- rnLExpr rhs
; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
; return (HsVect var' rhs', fv_rhs `addOneFV` unLoc var')
}
rnHsVectDecl (HsVect _var (Just _rhs))
rnHsVectDecl (HsVect _var _rhs)
= failWith $ vcat
[ ptext (sLit "IMPLEMENTATION RESTRICTION: right-hand side of a VECTORISE pragma")
, ptext (sLit "must be an identifier")
......
......@@ -739,17 +739,12 @@ tcVect :: VectDecl Name -> TcM (VectDecl TcId)
-- during type checking. Instead, constrain the rhs of a vectorisation declaration to be a single
-- identifier (this is checked in 'rnHsVectDecl'). Fix this by enabling the use of 'vectType'
-- from the vectoriser here.
tcVect (HsVect name Nothing)
= addErrCtxt (vectCtxt name) $
do { var <- wrapLocM tcLookupId name
; return $ HsVect var Nothing
}
tcVect (HsVect name (Just rhs))
tcVect (HsVect name rhs)
= addErrCtxt (vectCtxt name) $
do { var <- wrapLocM tcLookupId name
; let L rhs_loc (HsVar rhs_var_name) = rhs
; rhs_id <- tcLookupId rhs_var_name
; return $ HsVect var (Just $ L rhs_loc (HsVar rhs_id))
; return $ HsVect var (L rhs_loc (HsVar rhs_id))
}
{- OLD CODE:
......
......@@ -1081,7 +1081,7 @@ zonkVects env = mappM (wrapLocM (zonkVect env))
zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
zonkVect env (HsVect v e)
= do { v' <- wrapLocM (zonkIdBndr env) v
; e' <- fmapMaybeM (zonkLExpr env) e
; e' <- zonkLExpr env e
; return $ HsVect v' e'
}
zonkVect env (HsNoVect v)
......
This diff is collapsed.
......@@ -84,16 +84,16 @@ identityConv (AppTy {}) = noV $ text "identityConv: type appl. changes under
identityConv (FunTy {}) = noV $ text "identityConv: function type changes under vectorisation"
identityConv (ForAllTy {}) = noV $ text "identityConv: quantified type changes under vectorisation"
-- |Check that this type constructor is neutral under type vectorisation — i.e., it is not altered
-- by vectorisation as they contain no parallel arrays.
-- |Check that this type constructor is not changed by vectorisation — i.e., it does not embed any
-- parallel arrays.
--
identityConvTyCon :: TyCon -> VM ()
identityConvTyCon tc
| isBoxedTupleTyCon tc = return ()
| isUnLiftedTyCon tc = return ()
| otherwise
= do tc' <- maybeV notVectErr (lookupTyCon tc)
if tc == tc' then return () else noV idErr
= do
{ tc' <- lookupTyCon tc
; case tc' of
Nothing -> return ()
Just _ -> noV idErr
}
where
notVectErr = text "identityConvTyCon: no vectorised version for type constructor" <+> ppr tc
idErr = text "identityConvTyCon: type constructor contains parallel arrays" <+> ppr tc
idErr = text "identityConvTyCon: type constructor contains parallel arrays" <+> ppr tc
......@@ -31,7 +31,7 @@ import Name
import NameEnv
import FastString
import TysPrim
import TysWiredIn
--import TysWiredIn
import Data.Maybe
......@@ -60,7 +60,8 @@ data LocalEnv
-- ^Mapping from tyvars to their PA dictionaries.
, local_bind_name :: FastString
-- ^Local binding name.
-- ^Local binding name. This is only used to generate better names for hoisted
-- expressions.
}
-- |Create an empty local environment.
......@@ -84,35 +85,34 @@ data GlobalEnv
-- ^Mapping from global variables to their vectorised versions — aka the /vectorisation
-- map/.
, global_vect_decls :: VarEnv (Type, CoreExpr)
-- ^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_scalar_vars :: 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_tycons :: NameSet
-- ^Type constructors whose values can only contain scalar data. This includes type
-- constructors that appear in a 'VECTORISE SCALAR type' pragma or 'VECTORISE type' pragma
-- *without* a right-hand side in the current or an imported module as well as type
-- constructors that are automatically identified as scalar by the vectoriser (in
-- 'Vectorise.Type.Env'). Scalar code may only operate on such data.
, global_parallel_vars :: VarSet
-- ^The domain of 'global_vars'.
--
-- NB: Not all type constructors in that set are members of the 'Scalar' type class
-- (which can be trivially marshalled across scalar code boundaries).
, global_novect_vars :: VarSet
-- ^Variables that are not vectorised. (They may be referenced in the right-hand sides
-- of vectorisation declarations, though.)
-- This information is not redundant as it is impossible to extract the domain from a
-- 'VarEnv' (which is keyed on uniques alone). Moreover, we have mapped variables that
-- do not involve parallelism — e.g., the workers of vectorised, but scalar data types.
-- In addition, workers of parallel data types that we could not vectorise also need to
-- be tracked.
, global_vect_decls :: VarEnv (Maybe (Type, CoreExpr))
-- ^Mapping from global variables that have a vectorisation declaration to the right-hand
-- side of that declaration and its type and mapping variables that have NOVECTORISE
-- declarations to 'Nothing'.
, global_tycons :: NameEnv TyCon
-- ^Mapping from TyCons to their vectorised versions.
-- TyCons which do not have to be vectorised are mapped to themselves.
-- ^Mapping from TyCons to their vectorised versions. The vectorised version will be
-- identical to the original version if it is not changed by vectorisation. In any case,
-- if a tycon appears in the domain of this mapping, it was successfully vectorised.
, global_parallel_tycons :: NameSet
-- ^Type constructors whose definition directly or indirectly includes a parallel type,
-- such as '[::]'.
--
-- NB: This information is not redundant as some types have got a mapping in
-- 'global_tycons' (to a type other than themselves) and are still not parallel. An
-- example is '(->)'. Moreover, some types have *not* got a mapping in 'global_tycons'
-- (because they couldn't be vectorised), but still contain parallel types.
, global_datacons :: NameEnv DataCon
-- ^Mapping from DataCons to their vectorised versions.
......@@ -129,7 +129,7 @@ data GlobalEnv
-- ^External package inst-env & home-package inst-env for family instances.
, global_bindings :: [(Var, CoreExpr)]
-- ^Hoisted bindings.
-- ^Hoisted bindings — temporary storage for toplevel bindings during code gen.
}
-- |Create an initial global environment.
......@@ -143,9 +143,8 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
= GlobalEnv
{ global_vars = mapVarEnv snd $ vectInfoVar info
, global_vect_decls = mkVarEnv vects
, global_scalar_vars = vectInfoScalarVars info `extendVarSetList` scalar_vars
, global_scalar_tycons = vectInfoScalarTyCons info `addListToNameSet` scalar_tycons
, global_novect_vars = mkVarSet novects
, global_parallel_vars = vectInfoParallelVars info
, global_parallel_tycons = vectInfoParallelTyCons info
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = emptyNameEnv
......@@ -155,23 +154,12 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
, global_bindings = []
}
where
vects = [(var, (ty, exp)) | Vect var (Just exp@(Var rhs_var)) <- vectDecls
, let ty = varType rhs_var]
vects = [(var, Just (ty, exp)) | Vect var exp@(Var rhs_var) <- vectDecls
, let ty = varType rhs_var] ++
-- FIXME: we currently only allow RHSes consisting of a
-- single variable to be able to obtain the type without
-- inference — see also 'TcBinds.tcVect'
scalar_vars = [var | Vect var Nothing <- vectDecls] ++
[var | VectInst var <- vectDecls] ++
[dataConWrapId doubleDataCon, dataConWrapId floatDataCon, dataConWrapId intDataCon] -- TODO: fix this hack
novects = [var | NoVect var <- vectDecls]
scalar_tycons = [tyConName tycon | VectType True tycon Nothing <- vectDecls] ++
[tyConName tycon | VectType _ tycon (Just tycon') <- vectDecls
, tycon == tycon'] ++
map tyConName [doublePrimTyCon, intPrimTyCon, floatPrimTyCon] -- TODO: fix this hack
-- - for 'VectType True tycon Nothing', we checked that the type does not
-- contain arrays (or type variables that could be instatiated to arrays)
-- - for 'VectType _ tycon (Just tycon')', where the two tycons are the same,
-- we also know that there can be no embedded arrays
[(var, Nothing) | NoVect var <- vectDecls]
-- Operators on Global Environments -------------------------------------------
......@@ -210,11 +198,11 @@ setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps }
modVectInfo :: GlobalEnv -> [Id] -> [TyCon] -> [CoreVect]-> VectInfo -> VectInfo
modVectInfo env mg_ids mg_tyCons vectDecls info
= info
{ vectInfoVar = mk_env ids (global_vars env)
, vectInfoTyCon = mk_env tyCons (global_tycons env)
, vectInfoDataCon = mk_env dataCons (global_datacons env)
, vectInfoScalarVars = global_scalar_vars env `minusVarSet` vectInfoScalarVars info
, vectInfoScalarTyCons = global_scalar_tycons env `minusNameSet` vectInfoScalarTyCons info
{ vectInfoVar = mk_env ids (global_vars env)
, vectInfoTyCon = mk_env tyCons (global_tycons env)
, vectInfoDataCon = mk_env dataCons (global_datacons env)
, vectInfoParallelVars = global_parallel_vars env `minusVarSet` vectInfoParallelVars info
, vectInfoParallelTyCons = global_parallel_tycons env `minusNameSet` vectInfoParallelTyCons info
}
where
vectIds = [id | Vect id _ <- vectDecls] ++
......
This diff is collapsed.
......@@ -14,8 +14,8 @@ module Vectorise.Monad (
-- * Variables
lookupVar,
lookupVar_maybe,
addGlobalScalarVar,
addGlobalScalarTyCon,
addGlobalParallelVar,
addGlobalParallelTyCon,
) where
import Vectorise.Monad.Base
......@@ -172,22 +172,22 @@ dumpVar dflags var
= cantVectorise dflags "Variable not vectorised:" (ppr var)
-- Global scalars --------------------------------------------------------------
-- Global parallel entities ----------------------------------------------------
-- |Mark the given variable as scalar — i.e., executing the associated code does not involve any
-- |Mark the given variable as parallel — i.e., executing the associated code might involve
-- parallel array computations.
--
addGlobalScalarVar :: Var -> VM ()
addGlobalScalarVar var
= do { traceVt "addGlobalScalarVar" (ppr var)
; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var}
addGlobalParallelVar :: Var -> VM ()
addGlobalParallelVar var
= do { traceVt "addGlobalParallelVar" (ppr var)
; updGEnv $ \env -> env{global_parallel_vars = extendVarSet (global_parallel_vars env) var}
}
-- |Mark the given type constructor as scalar — i.e., its values cannot embed parallel arrays.
-- |Mark the given type constructor as parallel — i.e., its values might embed parallel arrays.
--
addGlobalScalarTyCon :: TyCon -> VM ()
addGlobalScalarTyCon tycon
= do { traceVt "addGlobalScalarTyCon" (ppr tycon)
addGlobalParallelTyCon :: TyCon -> VM ()
addGlobalParallelTyCon tycon
= do { traceVt "addGlobalParallelTyCon" (ppr tycon)
; updGEnv $ \env ->
env{global_scalar_tycons = addOneToNameSet (global_scalar_tycons env) (tyConName tycon)}
env{global_parallel_tycons = addOneToNameSet (global_parallel_tycons env) (tyConName tycon)}
}
......@@ -6,13 +6,13 @@ module Vectorise.Monad.Global (
updGEnv,
-- * Vars
defGlobalVar,
defGlobalVar, undefGlobalVar,
-- * Vectorisation declarations
lookupVectDecl, noVectDecl,
lookupVectDecl,
-- * Scalars
globalScalarVars, isGlobalScalarVar, globalScalarTyCons,
globalParallelVars, globalParallelTyCons,
-- * TyCons
lookupTyCon,
......@@ -93,48 +93,54 @@ defGlobalVar v v'
| otherwise
= ptext (sLit "in the current module")
-- |Remove the mapping of a variable in the vectorisation map.
--
undefGlobalVar :: Var -> VM ()
undefGlobalVar v
= do
{ traceVt "REMOVING global var mapping:" (ppr v)
; updGEnv $ \env -> env { global_vars = delVarEnv (global_vars env) v }
}
-- Vectorisation declarations -------------------------------------------------
-- |Check whether a variable has a (non-scalar) vectorisation declaration.
-- |Check whether a variable has a vectorisation declaration.
--
lookupVectDecl :: Var -> VM (Maybe (Type, CoreExpr))
lookupVectDecl var = readGEnv $ \env -> lookupVarEnv (global_vect_decls env) var
-- |Check whether a variable has a 'NOVECTORISE' declaration.
-- The first component of the result indicates whether the variable has a 'NOVECTORISE' declaration.
-- The second component contains the given type and expression in case of a 'VECTORISE' declaration.
--
noVectDecl :: Var -> VM Bool
noVectDecl var = readGEnv $ \env -> elemVarSet var (global_novect_vars env)
lookupVectDecl :: Var -> VM (Bool, Maybe (Type, CoreExpr))
lookupVectDecl var
= readGEnv $ \env ->
case lookupVarEnv (global_vect_decls env) var of
Nothing -> (False, Nothing)
Just Nothing -> (True, Nothing)
Just vectDecl -> (False, vectDecl)
-- Scalars --------------------------------------------------------------------
-- Parallel entities -----------------------------------------------------------
-- |Get the set of global scalar variables.
-- |Get the set of global parallel variables.
--
globalScalarVars :: VM VarSet
globalScalarVars = readGEnv global_scalar_vars
globalParallelVars :: VM VarSet
globalParallelVars = readGEnv global_parallel_vars
-- |Check whether a given variable is in the set of global scalar variables.
-- |Get the set of all parallel type constructors (those that may embed parallelism) including both
-- both those parallel type constructors declared in an imported module and those declared in the
-- current module.
--
isGlobalScalarVar :: Var -> VM Bool
isGlobalScalarVar var = readGEnv $ \env -> var `elemVarSet` global_scalar_vars env
-- |Get the set of global scalar type constructors including both those scalar type constructors
-- declared in an imported module and those declared in the current module.
--
globalScalarTyCons :: VM NameSet
globalScalarTyCons = readGEnv global_scalar_tycons
globalParallelTyCons :: VM NameSet
globalParallelTyCons = readGEnv global_parallel_tycons
-- TyCons ---------------------------------------------------------------------
-- |Lookup the vectorised version of a `TyCon` from the global environment.
-- |Determine the vectorised version of a `TyCon`. The vectorisation map in the global environment
-- contains a vectorised version if the original `TyCon` embeds any parallel arrays.
--
lookupTyCon :: TyCon -> VM (Maybe TyCon)
lookupTyCon tc
| isUnLiftedTyCon tc || isTupleTyCon tc
= return (Just tc)
| otherwise
= readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
-- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
......
module Vectorise.Monad.InstEnv
( lookupInst
( existsInst
, lookupInst
, lookupFamInst
)
where
......@@ -21,6 +22,14 @@ import Util
#include "HsVersions.h"
-- Check whether a unique class instance for a given class and type arguments exists.
--
existsInst :: Class -> [Type] -> VM Bool
existsInst cls tys
= do { instEnv <- readGEnv global_inst_env
; return $ either</