Skip to content

GitLab

Commit 18aae185 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files
Options

Fix newtype wrapper for 'PData[s] (Wrap a)' and fix VECTORISE type and instance pragmas 

* Correct usage of new type wrappers from MkId
* 'VECTORISE [SCALAR] type T = S' didn't work correctly across module boundaries
* Clean up 'VECTORISE SCALAR instance'
parent 498467cf
Hide whitespace changes
Inline Side-by-side
Showing with 226 additions and 157 deletions
compiler/coreSyn/CoreFVs.lhs
View file @ 18aae185
......@@ -333,7 +333,7 @@ vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs
vectFreeVars (VectClass _) = noFVs
vectFreeVars (VectInst _ _) = noFVs
vectFreeVars (VectInst _) = noFVs
-- this function is only concerned with values, not types
\end{code}
......
compiler/coreSyn/CoreSubst.lhs
View file @ 18aae185
......@@ -754,7 +754,7 @@ substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst r
substVect _subst vd@(NoVect _) = vd
substVect _subst vd@(VectType _ _ _) = vd
substVect _subst vd@(VectClass _) = vd
substVect _subst vd@(VectInst _ _) = vd
substVect _subst vd@(VectInst _) = vd
------------------
substVarSet :: Subst -> VarSet -> VarSet
......
compiler/coreSyn/CoreSyn.lhs
View file @ 18aae185
......@@ -538,7 +538,7 @@ data CoreVect = Vect Id (Maybe CoreExpr)
| NoVect Id
| VectType Bool TyCon (Maybe TyCon)
| VectClass TyCon -- class tycon
| VectInst Bool Id -- (1) whether SCALAR & (2) instance dfun
| VectInst Id -- instance dfun (always SCALAR)
\end{code}
......
compiler/coreSyn/PprCore.lhs
View file @ 18aae185
......@@ -510,6 +510,5 @@ instance Outputable CoreVect where
ppr (VectType True var (Just tc)) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+>
char '=' <+> ppr tc
ppr (VectClass tc) = ptext (sLit "VECTORISE class") <+> ppr tc
ppr (VectInst False var) = ptext (sLit "VECTORISE instance") <+> ppr var
ppr (VectInst True var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var
ppr (VectInst var) = ptext (sLit "VECTORISE SCALAR instance") <+> ppr var
\end{code}
compiler/deSugar/Desugar.lhs
View file @ 18aae185
......@@ -23,6 +23,7 @@ import TcRnTypes
import MkIface
import Id
import Name
import Type
import InstEnv
import Class
import Avail
......@@ -415,15 +416,19 @@ dsVect (L loc (HsVect (L _ v) rhs))
dsVect (L _loc (HsNoVect (L _ v)))
= return $ NoVect v
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
= return $ VectType isScalar tycon rhs_tycon
= return $ VectType isScalar tycon' rhs_tycon
where
tycon' | Just ty <- coreView $ mkTyConTy tycon
, (tycon', []) <- splitTyConApp ty = tycon'
| otherwise = tycon
dsVect vd@(L _ (HsVectTypeIn _ _ _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
dsVect (L _loc (HsVectClassOut cls))
= return $ VectClass (classTyCon cls)
dsVect vc@(L _ (HsVectClassIn _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectClassIn'" (ppr vc)
dsVect (L _loc (HsVectInstOut isScalar inst))
= return $ VectInst isScalar (instanceDFunId inst)
dsVect vi@(L _ (HsVectInstIn _ _))
dsVect (L _loc (HsVectInstOut inst))
= return $ VectInst (instanceDFunId inst)
dsVect vi@(L _ (HsVectInstIn _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
\end{code}
compiler/hsSyn/HsDecls.lhs
View file @ 18aae185
......@@ -1093,11 +1093,9 @@ data VectDecl name
(Located name)
| HsVectClassOut -- post type-checking
Class
| HsVectInstIn -- pre type-checking
Bool -- 'TRUE' => SCALAR declaration
| HsVectInstIn -- pre type-checking (always SCALAR)
(LHsType name)
| HsVectInstOut -- post type-checking
Bool -- 'TRUE' => SCALAR declaration
| HsVectInstOut -- post type-checking (always SCALAR)
Instance
deriving (Data, Typeable)
......@@ -1108,15 +1106,13 @@ lvectDeclName (L _ (HsVectTypeIn _ (L _ name) _)) = getName name
lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon
lvectDeclName (L _ (HsVectClassIn (L _ name))) = getName name
lvectDeclName (L _ (HsVectClassOut cls)) = getName cls
lvectDeclName (L _ (HsVectInstIn _ _)) = panic "HsDecls.lvectDeclName: HsVectInstIn"
lvectDeclName (L _ (HsVectInstOut _ _)) = panic "HsDecls.lvectDeclName: HsVectInstOut"
-- lvectDeclName (L _ (HsVectInstIn _ (L _ name))) = getName name
-- lvectDeclName (L _ (HsVectInstOut _ inst)) = getName inst
lvectDeclName (L _ (HsVectInstIn _)) = panic "HsDecls.lvectDeclName: HsVectInstIn"
lvectDeclName (L _ (HsVectInstOut _)) = panic "HsDecls.lvectDeclName: HsVectInstOut"
lvectInstDecl :: LVectDecl name -> Bool
lvectInstDecl (L _ (HsVectInstIn _ _)) = True
lvectInstDecl (L _ (HsVectInstOut _ _)) = True
lvectInstDecl _ = False
lvectInstDecl (L _ (HsVectInstIn _)) = True
lvectInstDecl (L _ (HsVectInstOut _)) = True
lvectInstDecl _ = False
instance OutputableBndr name => Outputable (VectDecl name) where
ppr (HsVect v Nothing)
......@@ -1147,13 +1143,9 @@ instance OutputableBndr name => Outputable (VectDecl name) where
= sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
ppr (HsVectClassOut c)
= sep [text "{-# VECTORISE class" <+> ppr c <+> text "#-}" ]
ppr (HsVectInstIn False ty)
= sep [text "{-# VECTORISE instance" <+> ppr ty <+> text "#-}" ]
ppr (HsVectInstIn True ty)
ppr (HsVectInstIn ty)
= sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ]
ppr (HsVectInstOut False i)
= sep [text "{-# VECTORISE instance" <+> ppr i <+> text "#-}" ]
ppr (HsVectInstOut True i)
ppr (HsVectInstOut i)
= sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ]
\end{code}
......
compiler/iface/TcIface.lhs
View file @ 18aae185
......@@ -728,10 +728,11 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
, ifaceVectInfoScalarTyCons = scalarTyCons
})
= do { let scalarTyConsSet = mkNameSet scalarTyCons
; vVars <- mapM vectVarMapping vars
; tyConRes1 <- mapM vectTyConMapping tycons
; tyConRes2 <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse
; vScalarVars <- mapM vectVar scalarVars
; vVars <- mapM vectVarMapping vars
; let varsSet = mkVarSet (map fst vVars)
; tyConRes1 <- mapM (vectTyConVectMapping varsSet) tycons
; tyConRes2 <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
; vScalarVars <- mapM vectVar scalarVars
; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2)
; return $ VectInfo
{ vectInfoVar = mkVarEnv vVars
......@@ -757,69 +758,51 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
= forkM (ptext (sLit "vect scalar var") <+> ppr name) $
tcIfaceExtId name
vectTyConMapping name
vectTyConVectMapping vars name
= do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
; vectTyConMapping vars name vName
}
vectTyConReuseMapping vars name
= vectTyConMapping vars name name
vectTyConMapping vars name vName
= do { tycon <- lookupLocalOrExternal name
; vTycon <- lookupLocalOrExternal vName
-- map the data constructors of the original type constructor to those of the
-- vectorised type constructor /unless/ the type constructor was vectorised
-- abstractly; if it was vectorised abstractly, the workers of its data constructors
-- do not appear in the set of vectorised variables
; let isAbstract | isClassTyCon tycon = False
| datacon:_ <- tyConDataCons tycon
= not $ dataConWrapId datacon `elemVarSet` vars
| otherwise = True
vDataCons | isAbstract = []
| otherwise = [ (dataConName datacon, (datacon, vDatacon))
| (datacon, vDatacon) <- zip (tyConDataCons tycon)
(tyConDataCons vTycon)
]
-- we need a fully defined version of the type constructor to be able to extract
-- its data constructors etc.
; tycon <- do { let mb_tycon = lookupTypeEnv typeEnv name
; case mb_tycon of
-- tycon is local
Just (ATyCon tycon) -> return tycon
-- name is not a tycon => internal inconsistency
Just _ -> notATyConErr
-- tycon is external
Nothing -> tcIfaceTyCon (IfaceTc name)
}
; vTycon <- forkM (text ("vect vTycon") <+> ppr vName) $
tcIfaceTyCon (IfaceTc vName)
-- we need to handle class type constructors differently due to the manner in which
-- the name for the dictionary data constructor is computed
; vDataCons <- if isClassTyCon tycon
then vectClassDataConMapping vName (tyConSingleDataCon_maybe tycon)
else mapM vectDataConMapping (tyConDataCons tycon)
; return ( (name, (tycon, vTycon)) -- (T, T_v)
, vDataCons -- list of (Ci, Ci_v)
)
}
where
notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
vectTyConReuseMapping scalarNames name
= do { tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
; if name `elemNameSet` scalarNames
then do
{ return ( (name, (tycon, tycon)) -- scalar type constructors expose no data..
, [] -- ..constructors see..
) -- .."Note [Pragmas to vectorise tycons]"..
-- ..in 'Vectorise.Type.Env'
} else do
{ let { vDataCons = [ (dataConName dc, (dc, dc))
| dc <- tyConDataCons tycon]
}
; return ( (name, (tycon, tycon)) -- (T, T)
, vDataCons -- list of (Ci, Ci)
)
}}
vectClassDataConMapping _vTyconName Nothing = panic "tcIfaceVectInfo: vectClassDataConMapping"
vectClassDataConMapping vTyconName (Just datacon)
= do { let name = dataConName datacon
; vName <- lookupOrig mod (mkClassDataConOcc . nameOccName $ vTyconName)
; vDataCon <- forkM (text ("vect class datacon") <+> ppr name) $
tcIfaceDataCon vName
; return [(name, (datacon, vDataCon))]
}
-- we need a fully defined version of the type constructor to be able to extract
-- its data constructors etc.
lookupLocalOrExternal name
= do { let mb_tycon = lookupTypeEnv typeEnv name
; case mb_tycon of
-- tycon is local
Just (ATyCon tycon) -> return tycon
-- name is not a tycon => internal inconsistency
Just _ -> notATyConErr
-- tycon is external
Nothing -> tcIfaceTyCon (IfaceTc name)
}
vectDataConMapping datacon
= do { let name = dataConName datacon
; vName <- lookupOrig mod (mkLocalisedOccName mod mkVectDataConOcc name)
; vDataCon <- forkM (text ("vect datacon") <+> ppr name) $
tcIfaceDataCon vName
; return (name, (datacon, vDataCon))
}
notATyConErr = pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
\end{code}
%************************************************************************
......
compiler/main/HscTypes.lhs
View file @ 18aae185
......@@ -1948,6 +1948,9 @@ data VectInfo
--
-- NB: The field 'ifaceVectInfoVar' explicitly contains the workers of data constructors as well as
-- class selectors — i.e., their mappings are /not/ implicitly generated from the data types.
-- Moreover, whether the worker of a data constructor is in 'ifaceVectInfoVar' determines
-- whether that data constructor was vectorised (or is part of an abstractly vectorised type
-- constructor).
--
data IfaceVectInfo
= IfaceVectInfo
......
compiler/parser/Parser.y.pp
View file @ 18aae185
......@@ -589,11 +589,12 @@ topdecl :: { OrdList (LHsDecl RdrName) }
| '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
{ unitOL $ LL $
VectD (HsVectTypeIn False $3 (Just $5)) }
| '{-# VECTORISE_SCALAR' 'type' gtycon '=' gtycon '#-}'
{ unitOL $ LL $
VectD (HsVectTypeIn True $3 (Just $5)) }
| '{-# VECTORISE' 'class' gtycon '#-}' { unitOL $ LL $ VectD (HsVectClassIn $3) }
| '{-# VECTORISE' 'instance' type '#-}'
{ unitOL $ LL $ VectD (HsVectInstIn False $3) }
| '{-# VECTORISE_SCALAR' 'instance' type '#-}'
{ unitOL $ LL $ VectD (HsVectInstIn True $3) }
{ unitOL $ LL $ VectD (HsVectInstIn $3) }
| annotation { unitOL $1 }
| decl { unLoc $1 }
......
compiler/rename/RnSource.lhs
View file @ 18aae185
......@@ -672,11 +672,11 @@ rnHsVectDecl (HsVectClassIn cls)
}
rnHsVectDecl (HsVectClassOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
rnHsVectDecl (HsVectInstIn isScalar instTy)
rnHsVectDecl (HsVectInstIn instTy)
= do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy
; return (HsVectInstIn isScalar instTy', emptyFVs)
; return (HsVectInstIn instTy', emptyFVs)
}
rnHsVectDecl (HsVectInstOut _ _)
rnHsVectDecl (HsVectInstOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
\end{code}
......
compiler/typecheck/TcBinds.lhs
View file @ 18aae185
......@@ -694,7 +694,11 @@ tcVect (HsNoVect name)
tcVect (HsVectTypeIn isScalar lname rhs_name)
= addErrCtxt (vectCtxt lname) $
do { tycon <- tcLookupLocatedTyCon lname
; checkTc (not isScalar || tyConArity tycon == 0) scalarTyConMustBeNullary
; checkTc ( not isScalar -- either we have a non-SCALAR declaration
|| isJust rhs_name -- or we explicitly provide a vectorised type
|| tyConArity tycon == 0 -- otherwise the type constructor must be nullary
)
scalarTyConMustBeNullary
; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
; return $ HsVectTypeOut isScalar tycon rhs_tycon
......@@ -708,13 +712,13 @@ tcVect (HsVectClassIn lname)
}
tcVect (HsVectClassOut _)
= panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
tcVect (HsVectInstIn isScalar linstTy)
tcVect (HsVectInstIn linstTy)
= addErrCtxt (vectCtxt linstTy) $
do { (cls, tys) <- tcHsVectInst linstTy
; inst <- tcLookupInstance cls tys
; return $ HsVectInstOut isScalar inst
; return $ HsVectInstOut inst
}
tcVect (HsVectInstOut _ _)
tcVect (HsVectInstOut _)
= panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
vectCtxt :: Outputable thing => thing -> SDoc
......
compiler/typecheck/TcHsSyn.lhs
View file @ 18aae185
......@@ -1063,9 +1063,9 @@ zonkVect _ (HsVectTypeIn _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
zonkVect _env (HsVectClassOut c)
= return $ HsVectClassOut c
zonkVect _ (HsVectClassIn _) = panic "TcHsSyn.zonkVect: HsVectClassIn"
zonkVect _env (HsVectInstOut s i)
= return $ HsVectInstOut s i
zonkVect _ (HsVectInstIn _ _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
zonkVect _env (HsVectInstOut i)
= return $ HsVectInstOut i
zonkVect _ (HsVectInstIn _) = panic "TcHsSyn.zonkVect: HsVectInstIn"
\end{code}
%************************************************************************
......
compiler/vectorise/Vectorise.hs
View file @ 18aae185
......@@ -87,8 +87,8 @@ vectModule guts@(ModGuts { mg_tcs = tycons
-- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers
-- NB: Need to vectorise the imported bindings first (local bindings may depend on them).
; let impBinds = [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id] ++
[imp_id | VectInst True imp_id <- vect_decls, isGlobalId imp_id]
; let impBinds = [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id] ++
[imp_id | VectInst imp_id <- vect_decls, isGlobalId imp_id]
; binds_imp <- mapM vectImpBind impBinds
; binds_top <- mapM vectTopBind binds
......@@ -150,7 +150,7 @@ vectTopBind b@(NonRec var expr)
; (inline, isScalar, expr') <- vectTopRhs [] var expr
; var' <- vectTopBinder var inline expr'
; when isScalar $
addGlobalScalar var
addGlobalScalarVar var
-- We replace the original top-level binding by a value projected from the vectorised
-- closure and add any newly created hoisted top-level bindings.
......@@ -182,7 +182,7 @@ vectTopBind b@(Rec bs)
; if and areScalars
then -- (1) Entire recursive group is scalar
-- => add all variables to the global set of scalars
do { mapM_ addGlobalScalar vars
do { mapM_ addGlobalScalarVar vars
; return (vars', inlines, exprs', hs)
}
else -- (2) At least one binding is not scalar
......@@ -226,7 +226,7 @@ vectImpBind var
; (inline, isScalar, expr') <- vectTopRhs [] var (Var var)
; var' <- vectTopBinder var inline expr'
; when isScalar $
addGlobalScalar var
addGlobalScalarVar var
-- We add any newly created hoisted top-level bindings.
; hs <- takeHoisted
......@@ -340,7 +340,7 @@ vectTopRhs :: [Var] -- ^ Names of all functions in the rec block
, CoreExpr) -- (3) the vectorised right-hand side
vectTopRhs recFs var expr
= closedV
$ do { globalScalar <- isGlobalScalar var
$ do { globalScalar <- isGlobalScalarVar var
; vectDecl <- lookupVectDecl var
; let isDFun = isDFunId var
......@@ -385,7 +385,7 @@ tryConvert :: Var -- ^ Name of the original binding (eg @foo@)
-> CoreExpr -- ^ The original body of the binding.
-> VM CoreExpr
tryConvert var vect_var rhs
= do { globalScalar <- isGlobalScalar var
= do { globalScalar <- isGlobalScalarVar var
; if globalScalar
then
return rhs
......
compiler/vectorise/Vectorise/Env.hs
View file @ 18aae185
......@@ -129,6 +129,10 @@ data GlobalEnv
-- |Create an initial global environment.
--
-- We add scalar variables and type constructors identified by vectorisation pragmas already here
-- to the global table, so that we can query scalarness during vectorisation, and especially, when
-- vectorising the scalar entities' definitions themselves.
--
initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv
initGlobalEnv info vectDecls instEnvs famInstEnvs
= GlobalEnv
......@@ -151,10 +155,16 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
-- 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 True var <- vectDecls]
novects = [var | NoVect var <- vectDecls]
scalar_tycons = [tyConName tycon | VectType True tycon _ <- vectDecls]
scalar_vars = [var | Vect var Nothing <- vectDecls] ++
[var | VectInst var <- vectDecls]
novects = [var | NoVect var <- vectDecls]
scalar_tycons = [tyConName tycon | VectType True tycon Nothing <- vectDecls] ++
[tyConName tycon | VectType _ tycon (Just tycon') <- vectDecls
, tycon == tycon']
-- - 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
-- Operators on Global Environments -------------------------------------------
......@@ -207,7 +217,7 @@ modVectInfo env mg_ids mg_tyCons vectDecls info
}
where
vectIds = [id | Vect id _ <- vectDecls] ++
[id | VectInst _ id <- vectDecls]
[id | VectInst id <- vectDecls]
vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls] ++
[tycon | VectClass tycon <- vectDecls]
vectDataCons = concatMap tyConDataCons vectTypeTyCons
......
compiler/vectorise/Vectorise/Monad.hs
View file @ 18aae185
......@@ -14,7 +14,8 @@ module Vectorise.Monad (
-- * Variables
lookupVar,
lookupVar_maybe,
addGlobalScalar,
addGlobalScalarVar,
addGlobalScalarTyCon,
) where
import Vectorise.Monad.Base
......@@ -32,6 +33,8 @@ import DynFlags
import MonadUtils (liftIO)
import InstEnv
import Class
import TyCon
import NameSet
import VarSet
import VarEnv
import Var
......@@ -174,8 +177,17 @@ dumpVar var
-- |Mark the given variable as scalar — i.e., executing the associated code does not involve any
-- parallel array computations.
--
addGlobalScalar :: Var -> VM ()
addGlobalScalar var
= do { traceVt "addGlobalScalar" (ppr var)
addGlobalScalarVar :: Var -> VM ()
addGlobalScalarVar var
= do { traceVt "addGlobalScalarVar" (ppr var)
; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var}
}
-- |Mark the given type constructor as scalar — i.e., its values cannot embed parallel arrays.
--
addGlobalScalarTyCon :: TyCon -> VM ()
addGlobalScalarTyCon tycon
= do { traceVt "addGlobalScalarTyCon" (ppr tycon)
; updGEnv $ \env ->
env{global_scalar_tycons = addOneToNameSet (global_scalar_tycons env) (tyConName tycon)}
}
compiler/vectorise/Vectorise/Monad/Global.hs
View file @ 18aae185
......@@ -12,7 +12,7 @@ module Vectorise.Monad.Global (
lookupVectDecl, noVectDecl,
-- * Scalars
globalScalarVars, isGlobalScalar, globalScalarTyCons,
globalScalarVars, isGlobalScalarVar, globalScalarTyCons,
-- * TyCons
lookupTyCon,
......@@ -96,8 +96,8 @@ 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 -> var `elemVarSet` global_scalar_vars env
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.
......
compiler/vectorise/Vectorise/Type/Env.hs
View file @ 18aae185
......@@ -32,14 +32,18 @@ import Id
import MkId
import NameEnv
import NameSet
import OccName
import Util
import Outputable
import FastString
import MonadUtils
import Control.Monad
import Data.Maybe
import Data.List
-- Note [Pragmas to vectorise tycons]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--
......@@ -60,7 +64,20 @@ import Data.List
-- Type constructors declared with {-# VECTORISE SCALAR type T #-} are treated in this manner.
-- (The vectoriser never treats a type constructor automatically in this manner.)
--
-- (2) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
-- (2) Data type constructor 'T' that may be used in vectorised code, where 'T' is represented by an
-- explicitly given 'Tv', but the representation of 'T' is opaque in vectorised code.
--
-- An example is the treatment of '[::]'. '[::]'s can be used in vectorised code and is
-- vectorised to 'PArray'. However, the representation of '[::]' is not exposed in vectorised
-- code. Instead, computations involving the representation need to be confined to scalar code.
--
-- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
-- by the vectoriser).
--
-- Type constructors declared with {-# VECTORISE SCALAR type T = T' #-} are treated in this
-- manner. (The vectoriser never treats a type constructor automatically in this manner.)
--
-- (3) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
-- code, where 'T' and the 'Cn' are automatically vectorised in the same manner as data types
-- declared in a vectorised module. This includes the case where the vectoriser determines that
-- the original representation of 'T' may be used in vectorised code (as it does not embed any
......@@ -74,13 +91,13 @@ import Data.List
--
-- Type constructors declared with {-# VECTORISE type T #-} are treated in this manner.
--
-- (3) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
-- (4) Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised
-- code, where 'T' is represented by an explicitly given 'Tv' whose constructors 'Cvn' represent
-- the original constructors in vectorised code. As a special case, we can have 'Tv = T'
--
-- An example is the treatment of 'Bool', which is represented by itself in vectorised code
-- (as it cannot embed any parallel arrays). However, we do not want any automatic generation
-- of class and family instances, which is why Case (2) does not apply.
-- of class and family instances, which is why Case (3) does not apply.
--
-- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated
-- by the vectoriser).
......@@ -139,35 +156,37 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
allScalarTyConNames
; let -- {-# VECTORISE SCALAR type T -#} (imported and local tycons)
localScalarTyCons = [tycon | VectType True tycon Nothing <- vectTypeDecls]
localAbstractTyCons = [tycon | VectType True tycon Nothing <- vectTypeDecls]
-- {-# VECTORISE type T -#} (ONLY the imported tycons)
impVectTyCons = ( [tycon | VectType False tycon Nothing <- vectTypeDecls]
++ [tycon | VectClass tycon <- vectClassDecls])
\\ tycons
-- {-# VECTORISE type T = ty -#} (imported and local tycons)
vectTyConsWithRHS = [ (tycon, rhs)
| VectType False tycon (Just rhs) <- vectTypeDecls]
-- {-# VECTORISE [SCALAR] type T = T' -#} (imported and local tycons)
vectTyConsWithRHS = [ (tycon, rhs, isAbstract)
| VectType isAbstract tycon (Just rhs) <- vectTypeDecls]
-- filter VECTORISE SCALAR tycons and VECTORISE tycons with explicit rhses
vectSpecialTyConNames = mkNameSet . map tyConName $
localScalarTyCons ++ map fst vectTyConsWithRHS
notLocalScalarTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames
localAbstractTyCons ++ map fst3 vectTyConsWithRHS
notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames
-- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2)
-- that we could, but don't need to vectorise. Type constructors that are not data
-- type constructors or use non-Haskell98 features are being dropped. They may not
-- appear in vectorised code. (We also drop the local type constructors appearing in a
-- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as
-- these are being handled separately.)
-- these are being handled separately. NB: Some type constructors may be marked SCALAR
-- /and/ have an explicit right-hand side.)
--
-- Furthermore, 'drop_tcs' are those type constructors that we cannot vectorise.
; let maybeVectoriseTyCons = filter notLocalScalarTyCon tycons ++ impVectTyCons
; let maybeVectoriseTyCons = filter notVectSpecialTyCon tycons ++ impVectTyCons
(conv_tcs, keep_tcs, drop_tcs) = classifyTyCons vectTyConFlavour maybeVectoriseTyCons
; traceVt " VECT SCALAR : " $ ppr localScalarTyCons
; traceVt " VECT SCALAR : " $ ppr localAbstractTyCons
; traceVt " VECT [class] : " $ ppr impVectTyCons
; traceVt " VECT with rhs : " $ ppr (map fst vectTyConsWithRHS)
; traceVt " VECT with rhs : " $ ppr (map fst3 vectTyConsWithRHS)
; traceVt " -- after classification (local and VECT [class] tycons) --" empty
; traceVt " reuse : " $ ppr keep_tcs
; traceVt " convert : " $ ppr conv_tcs
......@@ -180,24 +199,22 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
emitVt "Warning: cannot vectorise these type constructors:" $
pprQuotedList drop_tcs_nosyn $$ explanation
; let defTyConDataCons origTyCon vectTyCon
= do { defTyCon origTyCon vectTyCon
; MASSERT(length (tyConDataCons origTyCon) == length (tyConDataCons vectTyCon))
; zipWithM_ defDataCon (tyConDataCons origTyCon) (tyConDataCons vectTyCon)
}
-- For the type constructors that we don't need to vectorise, we use the original
-- representation in both unvectorised and vectorised code.
; zipWithM_ defTyConDataCons keep_tcs keep_tcs
-- We do the same for type constructors declared VECTORISE SCALAR, while ignoring their
-- representation (data constructors) — see "Note [Pragmas to vectorise tycons]".
; zipWithM_ defTyCon localScalarTyCons localScalarTyCons
-- For type constructors declared VECTORISE with an explicit vectorised type, we use the
-- explicitly given type in vectorised code and map data constructors one for one — see
-- "Note [Pragmas to vectorise tycons]".
; mapM_ (uncurry defTyConDataCons) vectTyConsWithRHS
; mapM_ addGlobalScalarTyCon keep_tcs
; let mapping =
-- Type constructors that we don't need to vectorise, use the same
-- representation in both unvectorised and vectorised code; they are not
-- abstract.
[(tycon, tycon, False) | tycon <- keep_tcs]