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

Add VECTORISE [SCALAR] type pragma

- Pragma to determine how a given type is vectorised
- At this stage only the VECTORISE SCALAR variant is used by the vectoriser.
- '{-# VECTORISE SCALAR type t #-}' implies that 't' cannot contain parallel arrays and may be used in vectorised code.  However, its constructors can only be used in scalar code.  We use this, e.g., for 'Int'.
- May be used on imported types

See also http://hackage.haskell.org/trac/ghc/wiki/DataParallel/VectPragma
parent 2d0438f3
......@@ -334,6 +334,8 @@ vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
vectFreeVars (Vect _ Nothing) = noFVs
vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _) = noFVs
-- this function is only concerned with values, not types
\end{code}
......
......@@ -735,7 +735,8 @@ 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 (NoVect v) = NoVect v
substVect _subst vd@(NoVect _) = vd
substVect _subst vd@(VectType _ _) = vd
------------------
substVarSet :: Subst -> VarSet -> VarSet
......
......@@ -87,12 +87,13 @@ import Coercion
import Name
import Literal
import DataCon
import TyCon
import BasicTypes
import FastString
import Outputable
import Util
import Data.Data
import Data.Data hiding (TyCon)
import Data.Word
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
......@@ -430,7 +431,7 @@ Representation of desugared vectorisation declarations that are fed to the vecto
\begin{code}
data CoreVect = Vect Id (Maybe CoreExpr)
| NoVect Id
| VectType TyCon (Maybe Type)
\end{code}
......
......@@ -477,4 +477,7 @@ instance Outputable CoreVect where
ppr (Vect var (Just e)) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
4 (pprCoreExpr e)
ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var
ppr (VectType var Nothing) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var
ppr (VectType var (Just ty)) = hang (ptext (sLit "VECTORISE type") <+> ppr var <+> char '=')
4 (ppr ty)
\end{code}
......@@ -406,4 +406,8 @@ dsVect (L loc (HsVect (L _ v) rhs))
}
dsVect (L _loc (HsNoVect (L _ v)))
= return $ NoVect v
dsVect (L _loc (HsVectTypeOut tycon ty))
= return $ VectType tycon ty
dsVect vd@(L _ (HsVectTypeIn _ _ty))
= pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
\end{code}
......@@ -59,6 +59,7 @@ import HsBinds
import HsPat
import HsTypes
import HsDoc
import TyCon
import NameSet
import {- Kind parts of -} Type
import BasicTypes
......@@ -72,7 +73,7 @@ import SrcLoc
import FastString
import Control.Monad ( liftM )
import Data.Data
import Data.Data hiding (TyCon)
import Data.Maybe ( isJust )
\end{code}
......@@ -1015,6 +1016,9 @@ A vectorisation pragma, one of
{-# VECTORISE SCALAR f #-}
{-# NOVECTORISE f #-}
{-# VECTORISE type T = ty #-}
{-# VECTORISE SCALAR type T #-}
Note [Typechecked vectorisation pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In case of the first variant of vectorisation pragmas (with an explicit expression),
......@@ -1036,11 +1040,19 @@ data VectDecl name
(Maybe (LHsExpr name)) -- 'Nothing' => SCALAR declaration
| HsNoVect
(Located name)
| HsVectTypeIn -- pre type-checking
(Located name)
(Maybe (LHsType name)) -- 'Nothing' => SCALAR declaration
| HsVectTypeOut -- post type-checking
TyCon
(Maybe Type) -- 'Nothing' => SCALAR declaration
deriving (Data, Typeable)
lvectDeclName :: LVectDecl name -> name
lvectDeclName :: Outputable name => LVectDecl name -> name
lvectDeclName (L _ (HsVect (L _ name) _)) = name
lvectDeclName (L _ (HsNoVect (L _ name))) = name
lvectDeclName (L _ (HsVectTypeIn (L _ name) _)) = name
lvectDeclName (L _ (HsVectTypeOut name _)) = pprPanic "HsDecls.HsVectTypeOut" (ppr name)
instance OutputableBndr name => Outputable (VectDecl name) where
ppr (HsVect v Nothing)
......@@ -1051,6 +1063,18 @@ instance OutputableBndr name => Outputable (VectDecl name) where
pprExpr (unLoc rhs) <+> text "#-}" ]
ppr (HsNoVect v)
= sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
ppr (HsVectTypeIn t Nothing)
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
ppr (HsVectTypeIn t (Just ty))
= sep [text "{-# VECTORISE type" <+> ppr t,
nest 4 $
ppr (unLoc ty) <+> text "#-}" ]
ppr (HsVectTypeOut t Nothing)
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
ppr (HsVectTypeOut t (Just ty))
= sep [text "{-# VECTORISE type" <+> ppr t,
nest 4 $
ppr ty <+> text "#-}" ]
\end{code}
%************************************************************************
......
......@@ -578,6 +578,10 @@ topdecl :: { OrdList (LHsDecl RdrName) }
| '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) }
| '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) }
| '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) }
| '{-# VECTORISE_SCALAR' 'type' qtycon '#-}'
{ unitOL $ LL $ VectD (HsVectTypeIn $3 Nothing) }
| '{-# VECTORISE' 'type' qtycon '=' ctype '#-}'
{ unitOL $ LL $ VectD (HsVectTypeIn $3 (Just $5)) }
| annotation { unitOL $1 }
| decl { unLoc $1 }
......
......@@ -659,18 +659,31 @@ badRuleLhsErr name lhs bad_e
\begin{code}
rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
rnHsVectDecl (HsVect var Nothing)
= do { var' <- wrapLocM lookupTopBndrRn var
= do { var' <- lookupLocatedTopBndrRn var
; return (HsVect var' Nothing, unitFV (unLoc var'))
}
rnHsVectDecl (HsVect var (Just rhs))
= do { var' <- wrapLocM lookupTopBndrRn var
= do { var' <- lookupLocatedTopBndrRn var
; (rhs', fv_rhs) <- rnLExpr rhs
; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
}
rnHsVectDecl (HsNoVect var)
= do { var' <- wrapLocM lookupTopBndrRn var
= do { var' <- lookupLocatedTopBndrRn var
; return (HsNoVect var', unitFV (unLoc var'))
}
rnHsVectDecl (HsVectTypeIn tycon Nothing)
= do { tycon' <- lookupLocatedOccRn tycon
; return (HsVectTypeIn tycon' Nothing, unitFV (unLoc tycon'))
}
rnHsVectDecl (HsVectTypeIn tycon (Just ty))
= do { tycon' <- lookupLocatedOccRn tycon
; (ty', fv_ty) <- rnHsTypeFVs vect_doc ty
; return (HsVectTypeIn tycon' (Just ty'), fv_ty `addOneFV` unLoc tycon')
}
where
vect_doc = text "In the VECTORISE pragma for type constructor" <+> quotes (ppr tycon)
rnHsVectDecl (HsVectTypeOut _ _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
\end{code}
%*********************************************************
......@@ -711,7 +724,7 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
return (ForeignType {tcdLName = name', tcdExtName = ext_name},
emptyFVs)
-- all flavours of type family declarations ("type family", "newtype family",
-- and "data family")
rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
......
......@@ -24,6 +24,7 @@ import TcSimplify
import TcHsType
import TcPat
import TcMType
import TyCon
import TcType
-- import Coercion
import TysPrim
......@@ -682,10 +683,23 @@ tcVect (HsNoVect name)
do { id <- wrapLocM tcLookupId name
; return $ HsNoVect id
}
tcVect (HsVectTypeIn lname@(L _ name) ty)
= addErrCtxt (vectCtxt lname) $
do { tycon <- tcLookupTyCon name
; checkTc (tyConArity tycon /= 0) scalarTyConMustBeNullary
; ty' <- fmapMaybeM dsHsType ty
; return $ HsVectTypeOut tycon ty'
}
tcVect (HsVectTypeOut _ _)
= panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
vectCtxt :: Located Name -> SDoc
vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name
scalarTyConMustBeNullary :: Message
scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")
--------------
-- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise
......
1%
%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1996-1998
%
......@@ -1022,19 +1022,20 @@ zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
zonkVects env = mappM (wrapLocM (zonkVect env))
zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
zonkVect env (HsVect v Nothing)
= do { v' <- wrapLocM (zonkIdBndr env) v
; return $ HsVect v' Nothing
}
zonkVect env (HsVect v (Just e))
zonkVect env (HsVect v e)
= do { v' <- wrapLocM (zonkIdBndr env) v
; e' <- zonkLExpr env e
; return $ HsVect v' (Just e')
; e' <- fmapMaybeM (zonkLExpr env) e
; return $ HsVect v' e'
}
zonkVect env (HsNoVect v)
= do { v' <- wrapLocM (zonkIdBndr env) v
; return $ HsNoVect v'
}
zonkVect _env (HsVectTypeOut t ty)
= do { ty' <- fmapMaybeM zonkTypeZapping ty
; return $ HsVectTypeOut t ty'
}
zonkVect _ (HsVectTypeIn _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
\end{code}
%************************************************************************
......
-- Main entry point to the vectoriser. It is invoked iff the option '-fvectorise' is passed.
--
-- This module provides the function 'vectorise', which vectorises an entire (desugared) module.
-- It vectorises all type declarations and value bindings. It also processes all VECTORISE pragmas
-- (aka vectorisation declarations), which can lead to the vectorisation of imported data types
-- and the enrichment of imported functions with vectorised versions.
module Vectorise ( vectorise )
where
......@@ -58,19 +64,19 @@ vectModule :: ModGuts -> VM ModGuts
vectModule guts@(ModGuts { mg_types = types
, mg_binds = binds
, mg_fam_insts = fam_insts
, mg_vect_decls = vect_decls
})
= do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $
pprCoreBindings binds
-- Vectorise the type environment.
-- This may add new TyCons and DataCons.
; (types', new_fam_insts, tc_binds) <- vectTypeEnv types
-- Vectorise the type environment. This will add vectorised type constructors, their
-- representaions, and the conrresponding data constructors. Moreover, we produce
-- bindings for dfuns and family instances of the classes and type families used in the
-- DPH library to represent array types.
; (types', new_fam_insts, tc_binds) <- vectTypeEnv types [vd | vd@(VectType _ _) <- vect_decls]
; (_, fam_inst_env) <- readGEnv global_fam_inst_env
-- dicts <- mapM buildPADict pa_insts
-- workers <- mapM vectDataConWorkers pa_insts
-- Vectorise all the top level bindings.
; binds' <- mapM vectTopBind binds
......
-- | Builtin types and functions used by the vectoriser.
-- The source program uses functions from Data.Array.Parallel, which the vectoriser rewrites
-- to use equivalent vectorised versions in the DPH backend packages.
-- Types and functions declared in the DPH packages and used by the vectoriser.
--
-- The `Builtins` structure holds the name of all the things in the DPH packages
-- we will need. We can get specific things using the selectors, which print a
-- The @Builtins@ structure holds the name of all the things in the DPH packages that appear in
-- code generated by the vectoriser. We can get specific things using the selectors, which print a
-- civilized panic message if the specified thing cannot be found.
--
module Vectorise.Builtins (
-- * Builtins
Builtins(..),
......
-- Set up the data structures provided by 'Vectorise.Builtins'.
module Vectorise.Builtins.Initialise (
-- * Initialisation
......
......@@ -92,8 +92,9 @@ data GlobalEnv
-- vectorisation declaration and those that the vectoriser determines to be scalar.
, global_scalar_tycons :: NameSet
-- ^Type constructors whose values can only contain scalar data. Scalar code may only
-- operate on such data.
-- ^Type constructors whose values can only contain scalar data and that appear in a
-- 'VECTORISE SCALAR type' pragma in the current or an imported module. Scalar code may
-- only operate on such data.
, global_novect_vars :: VarSet
-- ^Variables that are not vectorised. (They may be referenced in the right-hand sides
......@@ -135,8 +136,8 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
= GlobalEnv
{ global_vars = mapVarEnv snd $ vectInfoVar info
, global_vect_decls = mkVarEnv vects
, global_scalar_vars = vectInfoScalarVars info `extendVarSetList` scalars
, global_scalar_tycons = vectInfoScalarTyCons info
, global_scalar_vars = vectInfoScalarVars info `extendVarSetList` scalar_vars
, global_scalar_tycons = vectInfoScalarTyCons info `addListToNameSet` scalar_tycons
, global_novect_vars = mkVarSet novects
, global_exported_vars = emptyVarEnv
, global_tycons = mapNameEnv snd $ vectInfoTyCon info
......@@ -150,8 +151,9 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
}
where
vects = [(var, (varType var, exp)) | Vect var (Just exp) <- vectDecls]
scalars = [var | Vect var Nothing <- vectDecls]
scalar_vars = [var | Vect var Nothing <- vectDecls]
novects = [var | NoVect var <- vectDecls]
scalar_tycons = [tyConName tycon | VectType tycon Nothing <- vectDecls]
-- Operators on Global Environments -------------------------------------------
......
......@@ -26,6 +26,7 @@ import CoreFVs
import DataCon
import TyCon
import Type
import NameSet
import Var
import VarEnv
import VarSet
......@@ -194,25 +195,23 @@ vectScalarFun :: Bool -- ^ Was the function marked as scalar by the user?
-> CoreExpr -- ^ Expression to be vectorised
-> VM VExpr
vectScalarFun forceScalar recFns expr
= do { gscalars <- globalScalars
; let scalars = gscalars `extendVarSetList` recFns
= do { gscalarVars <- globalScalarVars
; scalarTyCons <- globalScalarTyCons
; let scalarVars = gscalarVars `extendVarSetList` recFns
(arg_tys, res_ty) = splitFunTys (exprType expr)
; MASSERT( not $ null arg_tys )
; onlyIfV (forceScalar -- user asserts the functions is scalar
||
all is_prim_ty arg_tys -- check whether the function is scalar
&& is_prim_ty res_ty
&& is_scalar scalars expr
&& uses scalars expr)
all (is_scalar_ty scalarTyCons) arg_tys -- check whether the function is scalar
&& is_scalar_ty scalarTyCons res_ty
&& is_scalar scalarVars (is_scalar_ty scalarTyCons) expr
&& uses scalarVars expr)
$ mkScalarFun arg_tys res_ty expr
}
where
-- FIXME: This is woefully insufficient!!! We need a scalar pragma for types!!!
is_prim_ty ty
| Just (tycon, []) <- splitTyConApp_maybe ty
= tycon == intTyCon
|| tycon == floatTyCon
|| tycon == doubleTyCon
is_scalar_ty scalarTyCons ty
| Just (tycon, _) <- splitTyConApp_maybe ty
= tyConName tycon `elemNameSet` scalarTyCons
| otherwise = False
-- Checks whether an expression contain a non-scalar subexpression.
......@@ -223,40 +222,45 @@ vectScalarFun forceScalar recFns expr
-- them to the list of scalar variables) and then check them. If one of them turns out not to
-- be scalar, the entire group is regarded as not being scalar.
--
-- FIXME: Currently, doesn't regard external (non-data constructor) variable and anonymous
-- data constructor as scalar. Should be changed once scalar types are passed
-- through VectInfo.
-- The second argument is a predicate that checks whether a type is scalar.
--
is_scalar :: VarSet -> CoreExpr -> Bool
is_scalar scalars (Var v) = v `elemVarSet` scalars
is_scalar _scalars (Lit _) = True
is_scalar scalars e@(App e1 e2)
is_scalar :: VarSet -> (Type -> Bool) -> CoreExpr -> Bool
is_scalar scalars _isScalarTC (Var v) = v `elemVarSet` scalars
is_scalar _scalars _isScalarTC (Lit _) = True
is_scalar scalars isScalarTC e@(App e1 e2)
| maybe_parr_ty (exprType e) = False
| otherwise = is_scalar scalars e1 && is_scalar scalars e2
is_scalar scalars (Lam var body)
| otherwise = is_scalar scalars isScalarTC e1 &&
is_scalar scalars isScalarTC e2
is_scalar scalars isScalarTC (Lam var body)
| maybe_parr_ty (varType var) = False
| otherwise = is_scalar (scalars `extendVarSet` var) body
is_scalar scalars (Let bind body) = bindsAreScalar && is_scalar scalars' body
| otherwise = is_scalar (scalars `extendVarSet` var)
isScalarTC body
is_scalar scalars isScalarTC (Let bind body) = bindsAreScalar &&
is_scalar scalars' isScalarTC body
where
(bindsAreScalar, scalars') = is_scalar_bind scalars bind
is_scalar scalars (Case e var ty alts)
| is_prim_ty ty = is_scalar scalars' e && all (is_scalar_alt scalars') alts
(bindsAreScalar, scalars') = is_scalar_bind scalars isScalarTC bind
is_scalar scalars isScalarTC (Case e var ty alts)
| isScalarTC ty = is_scalar scalars' isScalarTC e &&
all (is_scalar_alt scalars' isScalarTC) alts
| otherwise = False
where
scalars' = scalars `extendVarSet` var
is_scalar scalars (Cast e _coe) = is_scalar scalars e
is_scalar scalars (Note _ e ) = is_scalar scalars e
is_scalar _scalars (Type {}) = True
is_scalar _scalars (Coercion {}) = True
is_scalar scalars isScalarTC (Cast e _coe) = is_scalar scalars isScalarTC e
is_scalar scalars isScalarTC (Note _ e ) = is_scalar scalars isScalarTC e
is_scalar _scalars _isScalarTC (Type {}) = True
is_scalar _scalars _isScalarTC (Coercion {}) = True
-- Result: (<is this binding group scalar>, scalars ++ variables bound in this group)
is_scalar_bind scalars (NonRec var e) = (is_scalar scalars e, scalars `extendVarSet` var)
is_scalar_bind scalars (Rec bnds) = (all (is_scalar scalars') es, scalars')
is_scalar_bind scalars isScalarTCs (NonRec var e) = (is_scalar scalars isScalarTCs e,
scalars `extendVarSet` var)
is_scalar_bind scalars isScalarTCs (Rec bnds) = (all (is_scalar scalars' isScalarTCs) es,
scalars')
where
(vars, es) = unzip bnds
scalars' = scalars `extendVarSetList` vars
is_scalar_alt scalars (_, vars, e) = is_scalar (scalars `extendVarSetList ` vars) e
is_scalar_alt scalars isScalarTCs (_, vars, e) = is_scalar (scalars `extendVarSetList ` vars)
isScalarTCs e
-- Checks whether the type might be a parallel array type. In particular, if the outermost
-- constructor is a type family, we conservatively assume that it may be a parallel array type.
......
-- Operations on the global state of the vectorisation monad.
module Vectorise.Monad.Global (
readGEnv,
......@@ -11,12 +12,11 @@ module Vectorise.Monad.Global (
lookupVectDecl, noVectDecl,
-- * Scalars
globalScalars, isGlobalScalar,
globalScalarVars, isGlobalScalar, globalScalarTyCons,
-- * TyCons
lookupTyCon,
lookupBoxedTyCon,
defTyCon,
lookupTyCon, lookupBoxedTyCon,
defTyCon, globalVectTyCons,
-- * Datacons
lookupDataCon,
......@@ -24,7 +24,6 @@ module Vectorise.Monad.Global (
-- * PA Dictionaries
lookupTyConPA,
defTyConPA,
defTyConPAs,
-- * PR Dictionaries
......@@ -39,6 +38,7 @@ import Type
import TyCon
import DataCon
import NameEnv
import NameSet
import Var
import VarEnv
import VarSet
......@@ -93,13 +93,19 @@ noVectDecl var = readGEnv $ \env -> elemVarSet var (global_novect_vars env)
-- |Get the set of global scalar variables.
--
globalScalars :: VM VarSet
globalScalars = readGEnv global_scalar_vars
globalScalarVars :: VM VarSet
globalScalarVars = readGEnv global_scalar_vars
-- |Check whether a given variable is in the set of global scalar variables.
--
isGlobalScalar :: Var -> VM Bool
isGlobalScalar var = readGEnv $ \env -> elemVarSet var (global_scalar_vars env)
isGlobalScalar 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
-- TyCons ---------------------------------------------------------------------
......@@ -110,25 +116,32 @@ lookupTyCon :: TyCon -> VM (Maybe TyCon)
lookupTyCon tc
| isUnLiftedTyCon tc || isTupleTyCon tc
= return (Just tc)
| otherwise
= readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc)
-- | Lookup the vectorised version of a boxed `TyCon` from the global environment.
-- |Lookup the vectorised version of a boxed `TyCon` from the global environment.
--
lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon)
lookupBoxedTyCon tc
= readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env)
(tyConName tc)
-- | Add a mapping between plain and vectorised `TyCon`s to the global environment.
-- |Add a mapping between plain and vectorised `TyCon`s to the global environment.
--
defTyCon :: TyCon -> TyCon -> VM ()
defTyCon tc tc' = updGEnv $ \env ->
env { global_tycons = extendNameEnv (global_tycons env) (tyConName tc) tc' }
-- |Get the set of all vectorised type constructors.
--
globalVectTyCons :: VM (NameEnv TyCon)
globalVectTyCons = readGEnv global_tycons
-- DataCons -------------------------------------------------------------------
-- | Lookup the vectorised version of a `DataCon` from the global environment.
-- |Lookup the vectorised version of a `DataCon` from the global environment.
--
lookupDataCon :: DataCon -> VM (Maybe DataCon)
lookupDataCon dc
| isTupleTyCon (dataConTyCon dc)
......@@ -137,27 +150,24 @@ lookupDataCon dc
| otherwise
= readGEnv $ \env -> lookupNameEnv (global_datacons env) (dataConName dc)
-- | Add the mapping between plain and vectorised `DataCon`s to the global environment.
-- |Add the mapping between plain and vectorised `DataCon`s to the global environment.
--
defDataCon :: DataCon -> DataCon -> VM ()
defDataCon dc dc' = updGEnv $ \env ->
env { global_datacons = extendNameEnv (global_datacons env) (dataConName dc) dc' }
-- PA dictionaries ------------------------------------------------------------
-- | Lookup a PA `TyCon` from the global environment.
-- 'PA' dictionaries ------------------------------------------------------------
-- |Lookup the 'PA' dfun of a vectorised type constructor in the global environment.
--
lookupTyConPA :: TyCon -> VM (Maybe Var)
lookupTyConPA tc
= readGEnv $ \env -> lookupNameEnv (global_pa_funs env) (tyConName tc)
-- | Add a mapping between a PA TyCon and is vectorised version to the global environment.
defTyConPA :: TyCon -> Var -> VM ()
defTyConPA tc pa = updGEnv $ \env ->
env { global_pa_funs = extendNameEnv (global_pa_funs env) (tyConName tc) pa }
-- | Add several mapping between PA TyCons and their vectorised versions to the global environment.
-- |Associate vectorised type constructors with the dfun of their 'PA' instances in the global
-- environment.
--
defTyConPAs :: [(TyCon, Var)] -> VM ()
defTyConPAs ps = updGEnv $ \env ->
env { global_pa_funs = extendNameEnvList (global_pa_funs env)
......@@ -165,6 +175,7 @@ defTyConPAs ps = updGEnv $ \env ->
-- PR Dictionaries ------------------------------------------------------------
lookupTyConPR :: TyCon -> VM (Maybe Var)
lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
......
-- Extract from a list of type constructors those (1) which need to be vectorised and (2) those
-- that could be, but need not be vectorised (as a scalar representation is sufficient and more
-- efficient). The type constructors that cannot be vectorised will be dropped.
--
-- A type constructor will only be vectorised if it is
--
-- (1) a data type constructor, with vanilla data constructors (i.e., data constructors admitted by
-- Haskell 98) and
-- (2) at least one of the type constructors that appears in its definition is also vectorised.
--
-- If (1) is met, but not (2), the type constructor may appear in vectorised code, but there is no
-- need to vectorise that type constructor itself. This holds, for example, for all enumeration
-- types. As '([::])' is being vectorised, any type constructor whose definition involves
-- '([::])', either directly or indirectly, will be vectorised.
module Vectorise.Type.Classify (
classifyTyCons
) where
module Vectorise.Type.Classify
( TyConGroup
, classifyTyCons
, tyConGroups)
where
import UniqSet
import UniqFM
import DataCon
......@@ -13,29 +26,28 @@ import Type
import Digraph
import Outputable
type TyConGroup = ([TyCon], UniqSet TyCon)
-- | Split the given tycons into two sets depending on whether they have to be
-- converted (first list) or not (second list). The first argument contains
-- information about the conversion status of external tycons:
-- |From a list of type constructors, extract those thatcan be vectorised, returning them in two
-- sets, where the first result list /must be/ vectorised and the second result list /need not be/
-- vectroised.
-- The first argument determines the /conversion status/ of external type constructors as follows:
--
-- * tycons which have converted versions are mapped to True
-- * tycons which are not changed by vectorisation are mapped to False
-- * tycons which have converted versions are mapped to 'True'
-- * tycons which are not changed by vectorisation are mapped to 'False'
-- * tycons which can't be converted are not elements of the map
--
classifyTyCons