Skip to content

GitLab

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

Fully implement for VECTORISE type pragmas (non-SCALAR).

parent 29a97fde
Hide whitespace changes
Inline Side-by-side
Showing with 230 additions and 217 deletions
compiler/coreSyn/CoreFVs.lhs
View file @ fa278b82
......@@ -334,7 +334,7 @@ vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
vectFreeVars (Vect _ Nothing) = noFVs
vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
vectFreeVars (NoVect _) = noFVs
vectFreeVars (VectType _ _) = noFVs
vectFreeVars (VectType _ _ _) = noFVs
-- this function is only concerned with values, not types
\end{code}
......
compiler/coreSyn/CoreSubst.lhs
View file @ fa278b82
......@@ -745,7 +745,7 @@ 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@(VectType _ _ _) = vd
------------------
substVarSet :: Subst -> VarSet -> VarSet
......
compiler/coreSyn/CoreSyn.lhs
View file @ fa278b82
......@@ -433,7 +433,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)
| VectType Bool TyCon (Maybe TyCon)
\end{code}
......
compiler/coreSyn/PprCore.lhs
View file @ fa278b82
......@@ -473,11 +473,14 @@ pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn,
\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 '=')
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)
ppr (Vect var Nothing) = ptext (sLit "VECTORISE SCALAR") <+> ppr var
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 False var Nothing) = ptext (sLit "VECTORISE type") <+> ppr var
ppr (VectType True var Nothing) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var
ppr (VectType False var (Just tc)) = ptext (sLit "VECTORISE type") <+> ppr var <+> char '=' <+>
ppr tc
ppr (VectType True var (Just tc)) = ptext (sLit "VECTORISE SCALAR type") <+> ppr var <+>
char '=' <+> ppr tc
\end{code}
compiler/deSugar/Desugar.lhs
View file @ fa278b82
......@@ -408,8 +408,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))
dsVect (L _loc (HsVectTypeOut isScalar tycon rhs_tycon))
= return $ VectType isScalar tycon rhs_tycon
dsVect vd@(L _ (HsVectTypeIn _ _ _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectTypeIn'" (ppr vd)
\end{code}
compiler/hsSyn/HsDecls.lhs
View file @ fa278b82
......@@ -1076,18 +1076,20 @@ data VectDecl name
| HsNoVect
(Located name)
| HsVectTypeIn -- pre type-checking
Bool -- 'TRUE' => SCALAR declaration
(Located name)
(Maybe (LHsType name)) -- 'Nothing' => SCALAR declaration
(Maybe (Located name)) -- 'Nothing' => no right-hand side
| HsVectTypeOut -- post type-checking
Bool -- 'TRUE' => SCALAR declaration
TyCon
(Maybe Type) -- 'Nothing' => SCALAR declaration
(Maybe TyCon) -- 'Nothing' => no right-hand side
deriving (Data, Typeable)
lvectDeclName :: NamedThing name => LVectDecl name -> Name
lvectDeclName (L _ (HsVect (L _ name) _)) = getName name
lvectDeclName (L _ (HsNoVect (L _ name))) = getName name
lvectDeclName (L _ (HsVectTypeIn (L _ name) _)) = getName name
lvectDeclName (L _ (HsVectTypeOut tycon _)) = getName tycon
lvectDeclName (L _ (HsVect (L _ name) _)) = getName name
lvectDeclName (L _ (HsNoVect (L _ name))) = getName name
lvectDeclName (L _ (HsVectTypeIn _ (L _ name) _)) = getName name
lvectDeclName (L _ (HsVectTypeOut _ tycon _)) = getName tycon
instance OutputableBndr name => Outputable (VectDecl name) where
ppr (HsVect v Nothing)
......@@ -1098,18 +1100,22 @@ instance OutputableBndr name => Outputable (VectDecl name) where
pprExpr (unLoc rhs) <+> text "#-}" ]
ppr (HsNoVect v)
= sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ]
ppr (HsVectTypeIn t Nothing)
ppr (HsVectTypeIn False t Nothing)
= sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
ppr (HsVectTypeIn False t (Just t'))
= sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
ppr (HsVectTypeIn True 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)
ppr (HsVectTypeIn True t (Just t'))
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
ppr (HsVectTypeOut False t Nothing)
= sep [text "{-# VECTORISE type" <+> ppr t <+> text "#-}" ]
ppr (HsVectTypeOut False t (Just t'))
= sep [text "{-# VECTORISE type" <+> ppr t, text "=", ppr t', text "#-}" ]
ppr (HsVectTypeOut True 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 "#-}" ]
ppr (HsVectTypeOut True t (Just t'))
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
\end{code}
%************************************************************************
......
compiler/parser/Parser.y.pp
View file @ fa278b82
......@@ -580,10 +580,15 @@ 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)) }
| '{-# VECTORISE' 'type' gtycon '#-}'
{ unitOL $ LL $
VectD (HsVectTypeIn False $3 Nothing) }
| '{-# VECTORISE_SCALAR' 'type' gtycon '#-}'
{ unitOL $ LL $
VectD (HsVectTypeIn True $3 Nothing) }
| '{-# VECTORISE' 'type' gtycon '=' gtycon '#-}'
{ unitOL $ LL $
VectD (HsVectTypeIn False $3 (Just $5)) }
| annotation { unitOL $1 }
| decl { unLoc $1 }
......
compiler/rename/RnSource.lhs
View file @ fa278b82
......@@ -653,18 +653,17 @@ rnHsVectDecl (HsNoVect var)
= do { var' <- lookupLocatedTopBndrRn var -- only applies to local (not imported) names
; return (HsNoVect var', unitFV (unLoc var'))
}
rnHsVectDecl (HsVectTypeIn tycon Nothing)
rnHsVectDecl (HsVectTypeIn isScalar tycon Nothing)
= do { tycon' <- lookupLocatedOccRn tycon
; return (HsVectTypeIn tycon' Nothing, unitFV (unLoc tycon'))
; return (HsVectTypeIn isScalar 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')
rnHsVectDecl (HsVectTypeIn isScalar tycon (Just rhs_tycon))
= do { tycon' <- lookupLocatedOccRn tycon
; rhs_tycon' <- lookupLocatedOccRn rhs_tycon
; return ( HsVectTypeIn isScalar tycon' (Just rhs_tycon')
, mkFVs [unLoc tycon', unLoc rhs_tycon'])
}
where
vect_doc = ptext (sLit "In the VECTORISE pragma for type constructor") <+> quotes (ppr tycon)
rnHsVectDecl (HsVectTypeOut _ _)
rnHsVectDecl (HsVectTypeOut _ _ _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
\end{code}
......
compiler/typecheck/TcBinds.lhs
View file @ fa278b82
......@@ -691,15 +691,15 @@ tcVect (HsNoVect name)
do { var <- wrapLocM tcLookupId name
; return $ HsNoVect var
}
tcVect (HsVectTypeIn lname@(L _ name) ty)
tcVect (HsVectTypeIn isScalar lname@(L _ name) rhs_name)
= addErrCtxt (vectCtxt lname) $
do { tycon <- tcLookupTyCon name
; checkTc (tyConArity tycon == 0) scalarTyConMustBeNullary
; checkTc (not isScalar || tyConArity tycon == 0) scalarTyConMustBeNullary
; ty' <- fmapMaybeM dsHsType ty
; return $ HsVectTypeOut tycon ty'
; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
; return $ HsVectTypeOut isScalar tycon rhs_tycon
}
tcVect (HsVectTypeOut _ _)
tcVect (HsVectTypeOut _ _ _)
= panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
vectCtxt :: Located Name -> SDoc
......
compiler/typecheck/TcHsSyn.lhs
View file @ fa278b82
......@@ -1031,11 +1031,9 @@ 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"
zonkVect _env (HsVectTypeOut s t rt)
= return $ HsVectTypeOut s t rt
zonkVect _ (HsVectTypeIn _ _ _) = panic "TcHsSyn.zonkVect: HsVectTypeIn"
\end{code}
%************************************************************************
......
compiler/vectorise/Vectorise.hs
View file @ fa278b82
......@@ -76,7 +76,7 @@ vectModule guts@(ModGuts { mg_tcs = tycons
-- and type families used in the DPH library to represent
-- array types.
; (tycons', new_fam_insts, tc_binds) <- vectTypeEnv tycons [vd
| vd@(VectType _ _) <- vect_decls]
| vd@(VectType _ _ _) <- vect_decls]
; (_, fam_inst_env) <- readGEnv global_fam_inst_env
......
compiler/vectorise/Vectorise/Builtins.hs
View file @ fa278b82
......@@ -23,7 +23,7 @@ module Vectorise.Builtins (
closureCtrFun,
-- * Initialisation
initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
initBuiltins, initBuiltinVars, initBuiltinTyCons,
initBuiltinPAs, initBuiltinPRs,
-- * Lookup
......
compiler/vectorise/Vectorise/Builtins/Base.hs
View file @ fa278b82
-- | Builtin types and functions used by the vectoriser. These are all defined in the DPH package.
-- | Builtin types and functions used by the vectoriser.
-- These are all defined in the DPH package.
module Vectorise.Builtins.Base (
-- * Hard config
mAX_DPH_PROD,
mAX_DPH_SUM,
mAX_DPH_COMBINE,
mAX_DPH_SCALAR_ARGS,
-- * Builtins
Builtins(..),
indexBuiltin,
-- * Projections
-- * Hard config
mAX_DPH_PROD,
mAX_DPH_SUM,
mAX_DPH_COMBINE,
mAX_DPH_SCALAR_ARGS,
-- * Builtins
Builtins(..),
indexBuiltin,
-- * Projections
selTy,
selReplicate,
selPick,
selTags,
selElements,
sumTyCon,
prodTyCon,
prodDataCon,
combinePDVar,
scalarZip,
closureCtrFun
selReplicate,
selPick,
selTags,
selElements,
sumTyCon,
prodTyCon,
prodDataCon,
combinePDVar,
scalarZip,
closureCtrFun
) where
import Vectorise.Builtins.Modules
import BasicTypes
import Class
......@@ -56,79 +56,79 @@ data Builtins
= Builtins
{ dphModules :: Modules
-- From dph-common:Data.Array.Parallel.Lifted.PArray
, parrayTyCon :: TyCon -- ^ PArray
, parrayDataCon :: DataCon -- ^ PArray
, pdataTyCon :: TyCon -- ^ PData
-- From dph-common:Data.Array.Parallel.Lifted.PArray
, parrayTyCon :: TyCon -- ^ PArray
, parrayDataCon :: DataCon -- ^ PArray
, pdataTyCon :: TyCon -- ^ PData
, paClass :: Class -- ^ PA
, paTyCon :: TyCon -- ^ PA
, paDataCon :: DataCon -- ^ PA
, paTyCon :: TyCon -- ^ PA
, paDataCon :: DataCon -- ^ PA
, paPRSel :: Var -- ^ PA
, preprTyCon :: TyCon -- ^ PRepr
, preprTyCon :: TyCon -- ^ PRepr
, prClass :: Class -- ^ PR
, prTyCon :: TyCon -- ^ PR
, prDataCon :: DataCon -- ^ PR
, replicatePDVar :: Var -- ^ replicatePD
, emptyPDVar :: Var -- ^ emptyPD
, packByTagPDVar :: Var -- ^ packByTagPD
, combinePDVars :: Array Int Var -- ^ combinePD
, scalarClass :: Class -- ^ Scalar
, prTyCon :: TyCon -- ^ PR
, prDataCon :: DataCon -- ^ PR
, replicatePDVar :: Var -- ^ replicatePD
, emptyPDVar :: Var -- ^ emptyPD
, packByTagPDVar :: Var -- ^ packByTagPD
, combinePDVars :: Array Int Var -- ^ combinePD
, scalarClass :: Class -- ^ Scalar
-- From dph-common:Data.Array.Parallel.Lifted.Closure
, closureTyCon :: TyCon -- ^ :->
, closureVar :: Var -- ^ closure
, applyVar :: Var -- ^ $:
, liftedClosureVar :: Var -- ^ liftedClosure
, liftedApplyVar :: Var -- ^ liftedApply
, closureCtrFuns :: Array Int Var -- ^ closure1 .. closure2
-- From dph-common:Data.Array.Parallel.Lifted.Repr
, voidTyCon :: TyCon -- ^ Void
, wrapTyCon :: TyCon -- ^ Wrap
, closureTyCon :: TyCon -- ^ :->
, closureVar :: Var -- ^ closure
, applyVar :: Var -- ^ $:
, liftedClosureVar :: Var -- ^ liftedClosure
, liftedApplyVar :: Var -- ^ liftedApply
, closureCtrFuns :: Array Int Var -- ^ closure1 .. closure2
-- From dph-common:Data.Array.Parallel.Lifted.Repr
, voidTyCon :: TyCon -- ^ Void
, wrapTyCon :: TyCon -- ^ Wrap
, sumTyCons :: Array Int TyCon -- ^ Sum2 .. Sum3
, voidVar :: Var -- ^ void
, pvoidVar :: Var -- ^ pvoid
, fromVoidVar :: Var -- ^ fromVoid
, punitVar :: Var -- ^ punit
-- From dph-common:Data.Array.Parallel.Lifted.Selector
, selTys :: Array Int Type -- ^ Sel2
, selReplicates :: Array Int CoreExpr -- ^ replicate2
, selPicks :: Array Int CoreExpr -- ^ pick2
, selTagss :: Array Int CoreExpr -- ^ tagsSel2
, selEls :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1
-- From dph-common:Data.Array.Parallel.Lifted.Scalar
-- NOTE: map is counted as a zipWith fn with one argument array.
, scalarZips :: Array Int Var -- ^ map, zipWith, zipWith3
-- A Fresh variable
, liftingContext :: Var -- ^ lc
, voidVar :: Var -- ^ void
, pvoidVar :: Var -- ^ pvoid
, fromVoidVar :: Var -- ^ fromVoid
, punitVar :: Var -- ^ punit
-- From dph-common:Data.Array.Parallel.Lifted.Selector
, selTys :: Array Int Type -- ^ Sel2
, selReplicates :: Array Int CoreExpr -- ^ replicate2
, selPicks :: Array Int CoreExpr -- ^ pick2
, selTagss :: Array Int CoreExpr -- ^ tagsSel2
, selEls :: Array (Int, Int) CoreExpr -- ^ elementsSel2_0 .. elementsSel_2_1
-- From dph-common:Data.Array.Parallel.Lifted.Scalar
-- NOTE: map is counted as a zipWith fn with one argument array.
, scalarZips :: Array Int Var -- ^ map, zipWith, zipWith3
-- A Fresh variable
, liftingContext :: Var -- ^ lc
}
-- | Get an element from one of the arrays of contained by a `Builtins`.
-- If the indexed thing is not in the array then panic.
indexBuiltin
:: (Ix i, Outputable i)
=> String -- ^ Name of the selector we've used, for panic messages.
-> (Builtins -> Array i a) -- ^ Field selector for the `Builtins`.
-> i -- ^ Index into the array.
-> Builtins
-> a
:: (Ix i, Outputable i)
=> String -- ^ Name of the selector we've used, for panic messages.
-> (Builtins -> Array i a) -- ^ Field selector for the `Builtins`.
-> i -- ^ Index into the array.
-> Builtins
-> a
indexBuiltin fn f i bi
| inRange (bounds xs) i = xs ! i
| otherwise
| otherwise
= pprSorry "Vectorise.Builtins.indexBuiltin"
(vcat [ text ""
, text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> text "' is not yet implemented."
, text "This function does not appear in your source program, but it is needed"
, text "to compile your code in the backend. This is a known, current limitation"
, text "of DPH. If you want it to to work you should send mail to cvs-ghc@haskell.org"
, text "and ask what you can do to help (it might involve some GHC hacking)."])
(vcat [ text ""
, text "DPH builtin function '" <> text fn <> text "' of size '" <> ppr i <> text "' is not yet implemented."
, text "This function does not appear in your source program, but it is needed"
, text "to compile your code in the backend. This is a known, current limitation"
, text "of DPH. If you want it to to work you should send mail to cvs-ghc@haskell.org"
, text "and ask what you can do to help (it might involve some GHC hacking)."])
where xs = f bi
where xs = f bi
-- Projections ----------------------------------------------------------------
......@@ -136,44 +136,44 @@ indexBuiltin fn f i bi
-- because they give nicer panic messages if the indexed thing cannot be found.
selTy :: Int -> Builtins -> Type
selTy = indexBuiltin "selTy" selTys
selTy = indexBuiltin "selTy" selTys
selReplicate :: Int -> Builtins -> CoreExpr
selReplicate = indexBuiltin "selReplicate" selReplicates
selReplicate = indexBuiltin "selReplicate" selReplicates
selPick :: Int -> Builtins -> CoreExpr
selPick = indexBuiltin "selPick" selPicks
selPick = indexBuiltin "selPick" selPicks
selTags :: Int -> Builtins -> CoreExpr
selTags = indexBuiltin "selTags" selTagss
selTags = indexBuiltin "selTags" selTagss
selElements :: Int -> Int -> Builtins -> CoreExpr
selElements i j = indexBuiltin "selElements" selEls (i,j)
sumTyCon :: Int -> Builtins -> TyCon
sumTyCon = indexBuiltin "sumTyCon" sumTyCons
sumTyCon = indexBuiltin "sumTyCon" sumTyCons
prodTyCon :: Int -> Builtins -> TyCon
prodTyCon n _
| n >= 2 && n <= mAX_DPH_PROD
= tupleTyCon BoxedTuple n
| n >= 2 && n <= mAX_DPH_PROD
= tupleTyCon BoxedTuple n
| otherwise
= pprPanic "prodTyCon" (ppr n)
| otherwise
= pprPanic "prodTyCon" (ppr n)
prodDataCon :: Int -> Builtins -> DataCon
prodDataCon n bi
= case tyConDataCons (prodTyCon n bi) of
[con] -> con
_ -> pprPanic "prodDataCon" (ppr n)
[con] -> con
_ -> pprPanic "prodDataCon" (ppr n)
combinePDVar :: Int -> Builtins -> Var
combinePDVar = indexBuiltin "combinePDVar" combinePDVars
combinePDVar = indexBuiltin "combinePDVar" combinePDVars
scalarZip :: Int -> Builtins -> Var
scalarZip = indexBuiltin "scalarZip" scalarZips
scalarZip = indexBuiltin "scalarZip" scalarZips
closureCtrFun :: Int -> Builtins -> Var
closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
closureCtrFun = indexBuiltin "closureCtrFun" closureCtrFuns
compiler/vectorise/Vectorise/Builtins/Initialise.hs
View file @ fa278b82
......@@ -2,7 +2,7 @@
module Vectorise.Builtins.Initialise (
-- * Initialisation
initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons,
initBuiltins, initBuiltinVars, initBuiltinTyCons,
initBuiltinPAs, initBuiltinPRs
) where
......@@ -221,14 +221,10 @@ initBuiltinVars :: Builtins -> DsM [(Var, Var)]
initBuiltinVars (Builtins { dphModules = mods })
= do
cvars <- zipWithM externalVar cmods cfs
return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers]
++ zip (map dataConWorkId cons) cvars
return $ zip (map dataConWorkId cons) cvars
where
(cons, cmods, cfs) = unzip3 (preludeDataCons mods)
defaultDataConWorkers :: [DataCon]
defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon]
preludeDataCons :: Modules -> [(DataCon, Module, FastString)]
preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple })
= [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]]
......@@ -241,27 +237,12 @@ initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)]
initBuiltinTyCons bi
= do
-- parr <- externalTyCon dph_Prelude_PArr (fsLit "PArr")
dft_tcs <- defaultTyCons
return $ (tyConName funTyCon, closureTyCon bi)
: (parrTyConName, parrayTyCon bi)
-- FIXME: temporary
: (tyConName $ parrayTyCon bi, parrayTyCon bi)
: [(tyConName tc, tc) | tc <- dft_tcs]
where
defaultTyCons :: DsM [TyCon]
defaultTyCons = return [boolTyCon]
-- |Get a list of names to `DataCon`s in the mock prelude.
--
initBuiltinDataCons :: Builtins -> [(Name, DataCon)]
initBuiltinDataCons _
= [(dataConName dc, dc)| dc <- defaultDataCons]
where
defaultDataCons :: [DataCon]
defaultDataCons = [trueDataCon, falseDataCon, unitDataCon]
: []
-- |Get the names of all buildin instance functions for the PA class.
--
......
compiler/vectorise/Vectorise/Env.hs
View file @ fa278b82
......@@ -12,7 +12,6 @@ module Vectorise.Env (
setFamEnv,
extendFamEnv,
extendTyConsEnv,
extendDataConsEnv,
extendPAFunsEnv,
setPRFunsEnv,
modVectInfo
......@@ -90,9 +89,11 @@ 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 and that appear in a
-- 'VECTORISE SCALAR type' pragma in the current or an imported module. Scalar code may
-- only operate on such data.
-- ^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_novect_vars :: VarSet
-- ^Variables that are not vectorised. (They may be referenced in the right-hand sides
......@@ -147,7 +148,7 @@ initGlobalEnv info vectDecls instEnvs famInstEnvs
-- inference — see also 'TcBinds.tcVect'
scalar_vars = [var | Vect var Nothing <- vectDecls]
novects = [var | NoVect var <- vectDecls]
scalar_tycons = [tyConName tycon | VectType tycon Nothing <- vectDecls]
scalar_tycons = [tyConName tycon | VectType True tycon _ <- vectDecls]
-- Operators on Global Environments -------------------------------------------
......@@ -178,12 +179,6 @@ extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv
extendTyConsEnv ps genv
= genv { global_tycons = extendNameEnvList (global_tycons genv) ps }
-- |Extend the list of data constructors in an environment.
--
extendDataConsEnv :: [(Name, DataCon)] -> GlobalEnv -> GlobalEnv
extendDataConsEnv ps genv
= genv { global_datacons = extendNameEnvList (global_datacons genv) ps }
-- |Extend the list of PA functions in an environment.
--
extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv
......@@ -213,8 +208,8 @@ modVectInfo env tycons vectDecls info
, vectInfoScalarTyCons = global_scalar_tycons env `minusNameSet` vectInfoScalarTyCons info
}
where
vectIds = [id | Vect id _ <- vectDecls]
vectTypeTyCons = [tycon | VectType tycon _ <- vectDecls]
vectIds = [id | Vect id _ <- vectDecls]
vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls]
vectDataCons = concatMap tyConDataCons vectTypeTyCons
ids = {- typeEnvIds tyenv ++ -} vectIds
-- XXX: what Ids do you want here?
......
compiler/vectorise/Vectorise/Monad.hs
View file @ fa278b82
......@@ -84,7 +84,6 @@ initV hsc_env guts info thing_inside
; builtins <- initBuiltins pkg
; builtin_vars <- initBuiltinVars builtins
; builtin_tycons <- initBuiltinTyCons builtins
; let builtin_datacons = initBuiltinDataCons builtins
-- set up class and type family envrionments
; eps <- liftIO $ hscEPS hsc_env
......@@ -97,7 +96,6 @@ initV hsc_env guts info thing_inside
; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside
; let genv = extendImportedVarsEnv builtin_vars
. extendTyConsEnv builtin_tycons
. extendDataConsEnv builtin_datacons
. extendPAFunsEnv builtin_pas
. setPRFunsEnv builtin_prs
$ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
......