diff options
| -rw-r--r-- | compiler/coreSyn/CoreFVs.lhs | 2 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreSubst.lhs | 2 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreSyn.lhs | 2 | ||||
| -rw-r--r-- | compiler/coreSyn/PprCore.lhs | 17 | ||||
| -rw-r--r-- | compiler/deSugar/Desugar.lhs | 6 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.lhs | 38 | ||||
| -rw-r--r-- | compiler/parser/Parser.y.pp | 13 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 17 | ||||
| -rw-r--r-- | compiler/typecheck/TcBinds.lhs | 10 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsSyn.lhs | 8 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise.hs | 2 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Builtins.hs | 2 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Builtins/Base.hs | 186 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Builtins/Initialise.hs | 25 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Env.hs | 21 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad.hs | 2 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Type/Env.hs | 88 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Type/PData.hs | 6 |
18 files changed, 230 insertions, 217 deletions
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs index 71ddc8c8cc..5d8ded0044 100644 --- a/compiler/coreSyn/CoreFVs.lhs +++ b/compiler/coreSyn/CoreFVs.lhs @@ -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} diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs index fd40456ac8..4d58f14267 100644 --- a/compiler/coreSyn/CoreSubst.lhs +++ b/compiler/coreSyn/CoreSubst.lhs @@ -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 diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs index 2d5331aa0a..431683ae52 100644 --- a/compiler/coreSyn/CoreSyn.lhs +++ b/compiler/coreSyn/CoreSyn.lhs @@ -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} diff --git a/compiler/coreSyn/PprCore.lhs b/compiler/coreSyn/PprCore.lhs index 94f3e04a39..8f83a4c970 100644 --- a/compiler/coreSyn/PprCore.lhs +++ b/compiler/coreSyn/PprCore.lhs @@ -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} diff --git a/compiler/deSugar/Desugar.lhs b/compiler/deSugar/Desugar.lhs index 636677a86f..f18c793564 100644 --- a/compiler/deSugar/Desugar.lhs +++ b/compiler/deSugar/Desugar.lhs @@ -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} diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index 6686ef1033..20e0219843 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/compiler/hsSyn/HsDecls.lhs @@ -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} %************************************************************************ diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index e3da00d94e..66d8eccc83 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -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 } diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 79876caaf4..1f58e42065 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -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} diff --git a/compiler/typecheck/TcBinds.lhs b/compiler/typecheck/TcBinds.lhs index 4d2afd2ec4..49ef16e58e 100644 --- a/compiler/typecheck/TcBinds.lhs +++ b/compiler/typecheck/TcBinds.lhs @@ -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 diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs index fa97c9753d..87cd63ffdb 100644 --- a/compiler/typecheck/TcHsSyn.lhs +++ b/compiler/typecheck/TcHsSyn.lhs @@ -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} %************************************************************************ diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs index 083b2b05a5..daa2ed0725 100644 --- a/compiler/vectorise/Vectorise.hs +++ b/compiler/vectorise/Vectorise.hs @@ -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 diff --git a/compiler/vectorise/Vectorise/Builtins.hs b/compiler/vectorise/Vectorise/Builtins.hs index 6f5ffcf5f3..5545df825d 100644 --- a/compiler/vectorise/Vectorise/Builtins.hs +++ b/compiler/vectorise/Vectorise/Builtins.hs @@ -23,7 +23,7 @@ module Vectorise.Builtins ( closureCtrFun, -- * Initialisation - initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, + initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinPAs, initBuiltinPRs, -- * Lookup diff --git a/compiler/vectorise/Vectorise/Builtins/Base.hs b/compiler/vectorise/Vectorise/Builtins/Base.hs index 8d02b3e1ff..52eb887233 100644 --- a/compiler/vectorise/Vectorise/Builtins/Base.hs +++ b/compiler/vectorise/Vectorise/Builtins/Base.hs @@ -1,30 +1,30 @@ +-- | 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 diff --git a/compiler/vectorise/Vectorise/Builtins/Initialise.hs b/compiler/vectorise/Vectorise/Builtins/Initialise.hs index 4a9c8e2399..ac7b580bbc 100644 --- a/compiler/vectorise/Vectorise/Builtins/Initialise.hs +++ b/compiler/vectorise/Vectorise/Builtins/Initialise.hs @@ -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. -- diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs index 99c1e230de..a7578e4307 100644 --- a/compiler/vectorise/Vectorise/Env.hs +++ b/compiler/vectorise/Vectorise/Env.hs @@ -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? diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index 0c9766e33e..cef46fdb20 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/compiler/vectorise/Vectorise/Monad.hs @@ -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 diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index 35dbcb92e6..a91acab69d 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/compiler/vectorise/Vectorise/Type/Env.hs @@ -10,6 +10,8 @@ module Vectorise.Type.Env ( vectTypeEnv, ) where +#include "HsVersions.h" + import Vectorise.Env import Vectorise.Vect import Vectorise.Monad @@ -62,30 +64,32 @@ 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) [NOT FULLY IMPLEMENTED YET] --- Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised --- code, where 'T' and the 'Cn' represent themselves in vectorised code. +-- (2) 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 +-- parallel arrays.) This case is for type constructors that are *imported* from a non- +-- vectorised module, but that we want to use with full vectorisation support. -- --- An example is the treatment of 'Bool'. 'Bool' together with 'False' and 'True' may appear in --- vectorised code and they remain unchanged by vectorisation. (There is no need for a special --- representation as the values cannot embed any arrays.) +-- An example is the treatment of 'Ordering' and '[]'. The former remains unchanged by +-- vectorisation, whereas the latter is fully vectorised. -- 'PData' and 'PRepr' instances are automatically generated by the vectoriser. -- -- Type constructors declared with {-# VECTORISE type T #-} are treated in this manner. --- (This is the same treatment that type constructors receive that the vectoriser deems fit for --- use in vectorised code, but for which no special vectorised variant needs to be generated.) -- --- (3) [NOT IMPLEMENTED YET] --- Data type constructor 'T' that together with its constructors 'Cn' may be used in vectorised --- code, where 'T' is represented by 'Tv' and the workers of the 'Cn' are represented 'vCn' in --- vectorised code. +-- (3) 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' -- --- ??Example?? +-- 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. -- --- 'PData' and 'PRepr' instances are automatically generated by the vectoriser. +-- 'PData' and 'PRepr' instances need to be explicitly supplied for 'T' (they are not generated +-- by the vectoriser). -- --- ??How declared?? +-- Type constructors declared with {-# VECTORISE type T = T' #-} are treated in this manner. -- |Vectorise a type environment. -- @@ -105,31 +109,55 @@ vectTypeEnv tycons vectTypeDecls vectTyConFlavour = foldNameSet (\n env -> extendNameEnv env n False) vectTyConBase allScalarTyConNames + ; let -- {-# VECTORISE SCALAR type T -#} (imported and local tycons) + localScalarTyCons = [tycon | VectType True tycon Nothing <- vectTypeDecls] + + -- {-# VECTORISE type T -#} (ONLY the imported tycons) + impVectTyCons = [tycon | VectType False tycon Nothing <- vectTypeDecls] + \\ tycons + + -- {-# VECTORISE type T = ty -#} (imported and local tycons) + vectTyConsWithRHS = [ (tycon, rhs) + | VectType False 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 + -- 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, as they are being handled separately.) - ; let localScalarTyCons = [tycon | VectType tycon Nothing <- vectTypeDecls] - localScalarTyConNames = mkNameSet (map tyConName localScalarTyCons) - notLocalScalarTyCon tc = not $ (tyConName tc) `elemNameSet` localScalarTyConNames - - maybeVectoriseTyCons = filter notLocalScalarTyCon tycons + -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as + -- these are being handled separately.) + ; let maybeVectoriseTyCons = filter notLocalScalarTyCon tycons ++ impVectTyCons (conv_tcs, keep_tcs) = classifyTyCons vectTyConFlavour maybeVectoriseTyCons orig_tcs = keep_tcs ++ conv_tcs - keep_dcs = concatMap tyConDataCons keep_tcs - keep_and_scalar_tcs = keep_tcs ++ localScalarTyCons - - ; traceVt " declared SCALAR: " $ ppr localScalarTyCons + ; traceVt " VECT SCALAR : " $ ppr localScalarTyCons + ; traceVt " VECT with rhs : " $ ppr (map fst vectTyConsWithRHS) ; traceVt " reuse : " $ ppr keep_tcs ; traceVt " convert : " $ ppr conv_tcs - -- Of those type constructors that we don't need to vectorise, we use the original - -- representation in both unvectorised and vectorised code. For those declared VECTORISE - -- SCALAR, we ignore their represention — see "Note [Pragmas to vectorise tycons]". - ; zipWithM_ defTyCon keep_and_scalar_tcs keep_and_scalar_tcs - ; zipWithM_ defDataCon keep_dcs keep_dcs + ; 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 -- Vectorise all the data type declarations that we can and must vectorise. ; new_tcs <- vectTyConDecls conv_tcs diff --git a/compiler/vectorise/Vectorise/Type/PData.hs b/compiler/vectorise/Vectorise/Type/PData.hs index 34b6b35b1d..f8e5a93000 100644 --- a/compiler/vectorise/Vectorise/Type/PData.hs +++ b/compiler/vectorise/Vectorise/Type/PData.hs @@ -1,7 +1,8 @@ module Vectorise.Type.PData - (buildPDataTyCon - ) where + ( buildPDataTyCon + ) +where import Vectorise.Monad import Vectorise.Builtins @@ -19,7 +20,6 @@ import MonadUtils import Control.Monad - buildPDataTyCon :: TyCon -> TyCon -> SumRepr -> VM TyCon buildPDataTyCon orig_tc vect_tc repr = fixV $ \repr_tc -> do |