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 ...@@ -334,6 +334,8 @@ vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
vectFreeVars (Vect _ Nothing) = noFVs vectFreeVars (Vect _ Nothing) = noFVs
vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
vectFreeVars (NoVect _) = noFVs vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _) = noFVs
-- this function is only concerned with values, not types
\end{code} \end{code}
......
...@@ -735,7 +735,8 @@ substVects subst = map (substVect subst) ...@@ -735,7 +735,8 @@ substVects subst = map (substVect subst)
substVect :: Subst -> CoreVect -> CoreVect substVect :: Subst -> CoreVect -> CoreVect
substVect _subst (Vect v Nothing) = Vect v Nothing substVect _subst (Vect v Nothing) = Vect v Nothing
substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs)) 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 substVarSet :: Subst -> VarSet -> VarSet
......
...@@ -87,12 +87,13 @@ import Coercion ...@@ -87,12 +87,13 @@ import Coercion
import Name import Name
import Literal import Literal
import DataCon import DataCon
import TyCon
import BasicTypes import BasicTypes
import FastString import FastString
import Outputable import Outputable
import Util import Util
import Data.Data import Data.Data hiding (TyCon)
import Data.Word import Data.Word
infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
...@@ -428,9 +429,9 @@ Representation of desugared vectorisation declarations that are fed to the vecto ...@@ -428,9 +429,9 @@ Representation of desugared vectorisation declarations that are fed to the vecto
'ModGuts'). 'ModGuts').
\begin{code} \begin{code}
data CoreVect = Vect Id (Maybe CoreExpr) data CoreVect = Vect Id (Maybe CoreExpr)
| NoVect Id | NoVect Id
| VectType TyCon (Maybe Type)
\end{code} \end{code}
......
...@@ -473,8 +473,11 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, ...@@ -473,8 +473,11 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
\begin{code} \begin{code}
instance Outputable CoreVect where instance Outputable CoreVect where
ppr (Vect var Nothing) = ptext (sLit "VECTORISE SCALAR") <+> ppr var 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 (Just e)) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=')
4 (pprCoreExpr e) 4 (pprCoreExpr e)
ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var 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} \end{code}
...@@ -403,7 +403,11 @@ dsVect (L loc (HsVect (L _ v) rhs)) ...@@ -403,7 +403,11 @@ dsVect (L loc (HsVect (L _ v) rhs))
= putSrcSpanDs loc $ = putSrcSpanDs loc $
do { rhs' <- fmapMaybeM dsLExpr rhs do { rhs' <- fmapMaybeM dsLExpr rhs
; return $ Vect v rhs' ; return $ Vect v rhs'
} }
dsVect (L _loc (HsNoVect (L _ v))) dsVect (L _loc (HsNoVect (L _ v)))
= return $ NoVect 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} \end{code}
...@@ -59,6 +59,7 @@ import HsBinds ...@@ -59,6 +59,7 @@ import HsBinds
import HsPat import HsPat
import HsTypes import HsTypes
import HsDoc import HsDoc
import TyCon
import NameSet import NameSet
import {- Kind parts of -} Type import {- Kind parts of -} Type
import BasicTypes import BasicTypes
...@@ -72,7 +73,7 @@ import SrcLoc ...@@ -72,7 +73,7 @@ import SrcLoc
import FastString import FastString
import Control.Monad ( liftM ) import Control.Monad ( liftM )
import Data.Data import Data.Data hiding (TyCon)
import Data.Maybe ( isJust ) import Data.Maybe ( isJust )
\end{code} \end{code}
...@@ -1014,6 +1015,9 @@ A vectorisation pragma, one of ...@@ -1014,6 +1015,9 @@ A vectorisation pragma, one of
{-# VECTORISE f = closure1 g (scalar_map g) #-} {-# VECTORISE f = closure1 g (scalar_map g) #-}
{-# VECTORISE SCALAR f #-} {-# VECTORISE SCALAR f #-}
{-# NOVECTORISE f #-} {-# NOVECTORISE f #-}
{-# VECTORISE type T = ty #-}
{-# VECTORISE SCALAR type T #-}
Note [Typechecked vectorisation pragmas] Note [Typechecked vectorisation pragmas]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
...@@ -1036,11 +1040,19 @@ data VectDecl name ...@@ -1036,11 +1040,19 @@ data VectDecl name
(Maybe (LHsExpr name)) -- 'Nothing' => SCALAR declaration (Maybe (LHsExpr name)) -- 'Nothing' => SCALAR declaration
| HsNoVect | HsNoVect
(Located name) (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) deriving (Data, Typeable)
lvectDeclName :: LVectDecl name -> name lvectDeclName :: Outputable name => LVectDecl name -> name
lvectDeclName (L _ (HsVect (L _ name) _)) = name lvectDeclName (L _ (HsVect (L _ name) _)) = name
lvectDeclName (L _ (HsNoVect (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 instance OutputableBndr name => Outputable (VectDecl name) where
ppr (HsVect v Nothing) ppr (HsVect v Nothing)
...@@ -1051,6 +1063,18 @@ instance OutputableBndr name => Outputable (VectDecl name) where ...@@ -1051,6 +1063,18 @@ instance OutputableBndr name => Outputable (VectDecl name) where
pprExpr (unLoc rhs) <+> text "#-}" ] pprExpr (unLoc rhs) <+> text "#-}" ]
ppr (HsNoVect v) ppr (HsNoVect v)
= sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ] = 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} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -563,8 +563,8 @@ topdecls :: { OrdList (LHsDecl RdrName) } ...@@ -563,8 +563,8 @@ topdecls :: { OrdList (LHsDecl RdrName) }
| topdecl { $1 } | topdecl { $1 }
topdecl :: { OrdList (LHsDecl RdrName) } topdecl :: { OrdList (LHsDecl RdrName) }
: cl_decl { unitOL (L1 (TyClD (unLoc $1))) } : cl_decl { unitOL (L1 (TyClD (unLoc $1))) }
| ty_decl { unitOL (L1 (TyClD (unLoc $1))) } | ty_decl { unitOL (L1 (TyClD (unLoc $1))) }
| 'instance' inst_type where_inst | 'instance' inst_type where_inst
{ let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3)
in in
...@@ -575,9 +575,13 @@ topdecl :: { OrdList (LHsDecl RdrName) } ...@@ -575,9 +575,13 @@ topdecl :: { OrdList (LHsDecl RdrName) }
| '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# DEPRECATED' deprecations '#-}' { $2 }
| '{-# WARNING' warnings '#-}' { $2 } | '{-# WARNING' warnings '#-}' { $2 }
| '{-# RULES' rules '#-}' { $2 } | '{-# RULES' rules '#-}' { $2 }
| '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) } | '{-# 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 (Just $4)) }
| '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) } | '{-# 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 } | annotation { unitOL $1 }
| decl { unLoc $1 } | decl { unLoc $1 }
......
...@@ -659,24 +659,37 @@ badRuleLhsErr name lhs bad_e ...@@ -659,24 +659,37 @@ badRuleLhsErr name lhs bad_e
\begin{code} \begin{code}
rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars) rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars)
rnHsVectDecl (HsVect var Nothing) rnHsVectDecl (HsVect var Nothing)
= do { var' <- wrapLocM lookupTopBndrRn var = do { var' <- lookupLocatedTopBndrRn var
; return (HsVect var' Nothing, unitFV (unLoc var')) ; return (HsVect var' Nothing, unitFV (unLoc var'))
} }
rnHsVectDecl (HsVect var (Just rhs)) rnHsVectDecl (HsVect var (Just rhs))
= do { var' <- wrapLocM lookupTopBndrRn var = do { var' <- lookupLocatedTopBndrRn var
; (rhs', fv_rhs) <- rnLExpr rhs ; (rhs', fv_rhs) <- rnLExpr rhs
; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var') ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var')
} }
rnHsVectDecl (HsNoVect var) rnHsVectDecl (HsNoVect var)
= do { var' <- wrapLocM lookupTopBndrRn var = do { var' <- lookupLocatedTopBndrRn var
; return (HsNoVect var', unitFV (unLoc 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} \end{code}
%********************************************************* %*********************************************************
%* * %* *
\subsection{Type, class and iface sig declarations} \subsection{Type, class and iface sig declarations}
%* * %* *
%********************************************************* %*********************************************************
@rnTyDecl@ uses the `global name function' to create a new type @rnTyDecl@ uses the `global name function' to create a new type
...@@ -711,7 +724,7 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name}) ...@@ -711,7 +724,7 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdExtName = ext_name})
return (ForeignType {tcdLName = name', tcdExtName = ext_name}, return (ForeignType {tcdLName = name', tcdExtName = ext_name},
emptyFVs) emptyFVs)
-- all flavours of type family declarations ("type family", "newtype family",
-- and "data family") -- and "data family")
rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV rnTyClDecl tydecl@TyFamily {} = rnFamily tydecl bindTyVarsFV
......
...@@ -24,6 +24,7 @@ import TcSimplify ...@@ -24,6 +24,7 @@ import TcSimplify
import TcHsType import TcHsType
import TcPat import TcPat
import TcMType import TcMType
import TyCon
import TcType import TcType
-- import Coercion -- import Coercion
import TysPrim import TysPrim
...@@ -682,10 +683,23 @@ tcVect (HsNoVect name) ...@@ -682,10 +683,23 @@ tcVect (HsNoVect name)
do { id <- wrapLocM tcLookupId name do { id <- wrapLocM tcLookupId name
; return $ HsNoVect id ; 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 :: Located Name -> SDoc
vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name 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 -- If typechecking the binds fails, then return with each
-- signature-less binder given type (forall a.a), to minimise -- signature-less binder given type (forall a.a), to minimise
......
1% %
% (c) The University of Glasgow 2006 % (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1996-1998 % (c) The AQUA Project, Glasgow University, 1996-1998
% %
...@@ -1022,19 +1022,20 @@ zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] ...@@ -1022,19 +1022,20 @@ zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id]
zonkVects env = mappM (wrapLocM (zonkVect env)) zonkVects env = mappM (wrapLocM (zonkVect env))
zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id)
zonkVect env (HsVect v Nothing) zonkVect env (HsVect v e)
= do { v' <- wrapLocM (zonkIdBndr env) v
; return $ HsVect v' Nothing
}
zonkVect env (HsVect v (Just e))
= do { v' <- wrapLocM (zonkIdBndr env) v = do { v' <- wrapLocM (zonkIdBndr env) v
; e' <- zonkLExpr env e ; e' <- fmapMaybeM (zonkLExpr env) e
; return $ HsVect v' (Just e') ; return $ HsVect v' e'
} }
zonkVect env (HsNoVect v) zonkVect env (HsNoVect v)
= do { v' <- wrapLocM (zonkIdBndr env) v = do { v' <- wrapLocM (zonkIdBndr env) v
; return $ HsNoVect 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} \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 ) module Vectorise ( vectorise )
where where
...@@ -55,22 +61,22 @@ vectoriseIO hsc_env guts ...@@ -55,22 +61,22 @@ vectoriseIO hsc_env guts
-- | Vectorise a single module, in the VM monad. -- | Vectorise a single module, in the VM monad.
-- --
vectModule :: ModGuts -> VM ModGuts vectModule :: ModGuts -> VM ModGuts
vectModule guts@(ModGuts { mg_types = types vectModule guts@(ModGuts { mg_types = types
, mg_binds = binds , mg_binds = binds
, mg_fam_insts = fam_insts , mg_fam_insts = fam_insts
, mg_vect_decls = vect_decls
}) })
= do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $
pprCoreBindings binds pprCoreBindings binds
-- Vectorise the type environment. -- Vectorise the type environment. This will add vectorised type constructors, their
-- This may add new TyCons and DataCons. -- representaions, and the conrresponding data constructors. Moreover, we produce
; (types', new_fam_insts, tc_binds) <- vectTypeEnv types -- 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 ; (_, fam_inst_env) <- readGEnv global_fam_inst_env
-- dicts <- mapM buildPADict pa_insts
-- workers <- mapM vectDataConWorkers pa_insts
-- Vectorise all the top level bindings. -- Vectorise all the top level bindings.
; binds' <- mapM vectTopBind binds ; binds' <- mapM vectTopBind binds
......
-- Types and functions declared in the DPH packages and used by the vectoriser.
-- | 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.
--
-- 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
-- civilized panic message if the specified thing cannot be found.
-- --
-- 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 ( module Vectorise.Builtins (
-- * Builtins -- * Builtins
Builtins(..), Builtins(..),
......
-- Set up the data structures provided by 'Vectorise.Builtins'.
module Vectorise.Builtins.Initialise ( module Vectorise.Builtins.Initialise (
-- * Initialisation -- * Initialisation
...@@ -81,10 +82,10 @@ initBuiltins pkg ...@@ -81,10 +82,10 @@ initBuiltins pkg
-- From dph-common:Data.Array.Parallel.PArray.Types -- From dph-common:Data.Array.Parallel.PArray.Types
voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void") voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void")
voidVar <- externalVar dph_PArray_Types (fsLit "void") voidVar <- externalVar dph_PArray_Types (fsLit "void")
fromVoidVar <- externalVar dph_PArray_Types (fsLit "fromVoid") fromVoidVar <- externalVar dph_PArray_Types (fsLit "fromVoid")
wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap") wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap")
sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM) sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM)
-- from dph-common:Data.Array.Parallel.PArray.PDataInstances -- from dph-common:Data.Array.Parallel.PArray.PDataInstances
pvoidVar <- externalVar dph_PArray_PDataInstances (fsLit "pvoid") pvoidVar <- externalVar dph_PArray_PDataInstances (fsLit "pvoid")
......
...@@ -76,55 +76,56 @@ emptyLocalEnv = LocalEnv { ...@@ -76,55 +76,56 @@ emptyLocalEnv = LocalEnv {
-- --
data GlobalEnv data GlobalEnv
= GlobalEnv = GlobalEnv
{ global_vars :: VarEnv Var { global_vars :: VarEnv Var
-- ^Mapping from global variables to their vectorised versions — aka the /vectorisation -- ^Mapping from global variables to their vectorised versions — aka the /vectorisation
-- map/. -- map/.
, global_vect_decls :: VarEnv (Type, CoreExpr) , global_vect_decls :: VarEnv (Type, CoreExpr)
-- ^Mapping from global variables that have a vectorisation declaration to the right-hand -- ^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 -- side of that declaration and its type. This mapping only applies to non-scalar
-- vectorisation declarations. All variables with a scalar vectorisation declaration are -- vectorisation declarations. All variables with a scalar vectorisation declaration are
-- mentioned in 'global_scalars_vars'. -- mentioned in 'global_scalars_vars'.
, global_scalar_vars :: VarSet , global_scalar_vars :: VarSet
-- ^Purely scalar variables. Code which mentions only these variables doesn't have to be -- ^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 -- lifted. This includes variables from the current module that have a scalar
-- vectorisation declaration and those that the vectoriser determines to be scalar. -- vectorisation declaration and those that the vectoriser determines to be scalar.
, global_scalar_tycons :: NameSet , global_scalar_tycons :: NameSet
-- ^Type constructors whose values can only contain scalar data. Scalar code may only -- ^Type constructors whose values can only contain scalar data and that appear in a
-- operate on such data. -- 'VECTORISE SCALAR type' pragma in the current or an imported module. Scalar code may
-- only operate on such data.
, global_novect_vars :: VarSet , global_novect_vars :: VarSet
-- ^Variables that are not vectorised. (They may be referenced in the right-hand sides -- ^Variables that are not vectorised. (They may be referenced in the right-hand sides
-- of vectorisation declarations, though.) -- of vectorisation declarations, though.)
, global_exported_vars :: VarEnv (Var, Var) , global_exported_vars :: VarEnv (Var, Var)
-- ^Exported variables which have a vectorised version. -- ^Exported variables which have a vectorised version.
, global_tycons :: NameEnv TyCon , global_tycons :: NameEnv TyCon
-- ^Mapping from TyCons to their vectorised versions. -- ^Mapping from TyCons to their vectorised versions.
-- TyCons which do not have to be vectorised are mapped to themselves. -- TyCons which do not have to be vectorised are mapped to themselves.
, global_datacons :: NameEnv DataCon , global_datacons :: NameEnv DataCon
-- ^Mapping from DataCons to their vectorised versions. -- ^Mapping from DataCons to their vectorised versions.
, global_pa_funs :: NameEnv Var , global_pa_funs :: NameEnv Var
-- ^Mapping from TyCons to their PA dfuns. -- ^Mapping from TyCons to their PA dfuns.
, global_pr_funs :: NameEnv Var , global_pr_funs :: NameEnv Var
-- ^Mapping from TyCons to their PR dfuns. -- ^Mapping from TyCons to their PR dfuns.
, global_boxed_tycons :: NameEnv TyCon , global_boxed_tycons :: NameEnv TyCon
-- ^Mapping from unboxed TyCons to their boxed versions. -- ^Mapping from unboxed TyCons to their boxed versions.
, global_inst_env :: (InstEnv, InstEnv) , global_inst_env :: (InstEnv, InstEnv)
-- ^External package inst-env & home-package inst-env for class instances. -- ^External package inst-env & home-package inst-env for class instances.
, global_fam_inst_env :: FamInstEnvs , global_fam_inst_env :: FamInstEnvs
-- ^External package inst-env & home-package inst-env for family instances. -- ^External package inst-env & home-package inst-env for family instances.
, global_bindings :: [(Var, CoreExpr)] , global_bindings :: [(Var, CoreExpr)]
-- ^Hoisted bindings. -- ^Hoisted bindings.
} }
...@@ -133,25 +134,26 @@ data GlobalEnv ...@@ -133,25 +134,26 @@ data GlobalEnv
initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
initGlobalEnv info vectDecls instEnvs famInstEnvs initGlobalEnv info vectDecls instEnvs famInstEnvs
= GlobalEnv = GlobalEnv
{ global_vars = mapVarEnv snd $ vectInfoVar info { global_vars = mapVarEnv snd $ vectInfoVar info
, global_vect_decls = mkVarEnv vects , global_vect_decls = mkVarEnv vects
, global_scalar_vars = vectInfoScalarVars info `extendVarSetList` scalars , global_scalar_vars = vectInfoScalarVars info `extendVarSetList` scalar_vars
, global_scalar_tycons = vectInfoScalarTyCons info , global_scalar_tycons = vectInfoScalarTyCons info `addListToNameSet` scalar_tycons
, global_novect_vars = mkVarSet novects , global_novect_vars = mkVarSet novects
, global_exported_vars = emptyVarEnv , global_exported_vars = emptyVarEnv
, global_tycons = mapNameEnv snd $ vectInfoTyCon info , global_tycons = mapNameEnv snd $ vectInfoTyCon info
, global_datacons = mapNameEnv snd $ vectInfoDataCon info , global_datacons = mapNameEnv snd $ vectInfoDataCon info
, global_pa_funs = mapNameEnv snd $ vectInfoPADFun info , global_pa_funs = mapNameEnv snd $ vectInfoPADFun info
, global_pr_funs = emptyNameEnv , global_pr_funs = emptyNameEnv
, global_boxed_tycons = emptyNameEnv , global_boxed_tycons = emptyNameEnv
, global_inst_env = instEnvs , global_inst_env = instEnvs
, global_fam_inst_env = famInstEnvs , global_fam_inst_env = famInstEnvs
, global_bindings = [] , global_bindings = []
} }
where where
vects = [(var, (varType var, exp)) | Vect var (Just exp) <- vectDecls] 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] novects = [var | NoVect var <- vectDecls]
scalar_tycons = [tyConName tycon | VectType tycon Nothing <- vectDecls]