Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
fa278b82
Commit
fa278b82
authored
Oct 10, 2011
by
chak@cse.unsw.edu.au.
Browse files
Fully implement for VECTORISE type pragmas (non-SCALAR).
parent
29a97fde
Changes
18
Hide whitespace changes
Inline
Side-by-side
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 Ty
pe
)
| VectType
Bool
TyCon (Maybe Ty
Con
)
\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 (L
HsType
name)) -- 'Nothing' =>
SCALAR declaration
(Maybe (L
ocated
name)) -- 'Nothing' =>
no right-hand side
| HsVectTypeOut -- post type-checking
Bool -- 'TRUE' => SCALAR declaration
TyCon
(Maybe Ty
pe)
-- 'Nothing' =>
SCALAR declaration
(Maybe Ty
Con)
-- '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