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
c439818a
Commit
c439818a
authored
Oct 31, 2011
by
chak@cse.unsw.edu.au.
Browse files
VECTORISE pragmas for type classes and instances
* Frontend support (not yet used in the vectoriser)
parent
f05b36dc
Changes
20
Hide whitespace changes
Inline
Side-by-side
compiler/basicTypes/BasicTypes.lhs
View file @
c439818a
...
...
@@ -365,7 +365,7 @@ data OverlapFlag
-- instantiating 'b' would change which instance
-- was chosen
| Incoherent { isSafeOverlap :: Bool }
deriving
( Eq
)
deriving
(Eq, Data, Typeable
)
instance Outputable OverlapFlag where
ppr (NoOverlap b) = empty <+> pprSafeOverlap b
...
...
compiler/coreSyn/CoreSubst.lhs
View file @
c439818a
...
...
@@ -743,10 +743,12 @@ substVects subst = map (substVect subst)
------------------
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 (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@(VectClass _) = vd
substVect _subst vd@(VectInst _ _) = vd
------------------
substVarSet :: Subst -> VarSet -> VarSet
...
...
compiler/coreSyn/CoreSyn.lhs
View file @
c439818a
...
...
@@ -431,9 +431,11 @@ Representation of desugared vectorisation declarations that are fed to the vecto
'ModGuts').
\begin{code}
data CoreVect = Vect Id (Maybe CoreExpr)
| NoVect Id
| VectType Bool TyCon (Maybe TyCon)
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
\end{code}
...
...
compiler/coreSyn/PprCore.lhs
View file @
c439818a
...
...
@@ -482,4 +482,7 @@ instance Outputable CoreVect where
ppr tc
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
\end{code}
compiler/deSugar/Desugar.lhs
View file @
c439818a
...
...
@@ -16,6 +16,8 @@ import TcRnTypes
import MkIface
import Id
import Name
import InstEnv
import Class
import Avail
import CoreSyn
import CoreSubst
...
...
@@ -412,4 +414,12 @@ 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)
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 _ _))
= pprPanic "Desugar.dsVect: unexpected 'HsVectInstIn'" (ppr vi)
\end{code}
compiler/hsSyn/HsDecls.lhs
View file @
c439818a
...
...
@@ -28,7 +28,7 @@ module HsDecls (
collectRuleBndrSigTys,
-- ** @VECTORISE@ declarations
VectDecl(..), LVectDecl,
lvectDeclName,
lvectDeclName,
lvectInstDecl,
-- ** @default@ declarations
DefaultDecl(..), LDefaultDecl,
-- ** Top-level template haskell splice
...
...
@@ -69,6 +69,7 @@ import Coercion
import ForeignCall
-- others:
import InstEnv
import Class
import Outputable
import Util
...
...
@@ -1083,13 +1084,34 @@ data VectDecl name
Bool -- 'TRUE' => SCALAR declaration
TyCon
(Maybe TyCon) -- 'Nothing' => no right-hand side
| HsVectClassIn -- pre type-checking
(Located name)
| HsVectClassOut -- post type-checking
Class
| HsVectInstIn -- pre type-checking
Bool -- 'TRUE' => SCALAR declaration
(LHsType name)
| HsVectInstOut -- post type-checking
Bool -- 'TRUE' => SCALAR declaration
Instance
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
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
lvectInstDecl :: LVectDecl name -> Bool
lvectInstDecl (L _ (HsVectInstIn _ _)) = True
lvectInstDecl (L _ (HsVectInstOut _ _)) = True
lvectInstDecl _ = False
instance OutputableBndr name => Outputable (VectDecl name) where
ppr (HsVect v Nothing)
...
...
@@ -1116,6 +1138,18 @@ instance OutputableBndr name => Outputable (VectDecl name) where
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t <+> text "#-}" ]
ppr (HsVectTypeOut True t (Just t'))
= sep [text "{-# VECTORISE SCALAR type" <+> ppr t, text "=", ppr t', text "#-}" ]
ppr (HsVectClassIn c)
= 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)
= sep [text "{-# VECTORISE SCALAR instance" <+> ppr ty <+> text "#-}" ]
ppr (HsVectInstOut False i)
= sep [text "{-# VECTORISE instance" <+> ppr i <+> text "#-}" ]
ppr (HsVectInstOut True i)
= sep [text "{-# VECTORISE SCALAR instance" <+> ppr i <+> text "#-}" ]
\end{code}
%************************************************************************
...
...
compiler/parser/Parser.y.pp
View file @
c439818a
...
...
@@ -589,6 +589,11 @@ topdecl :: { OrdList (LHsDecl RdrName) }
|
'{-# VECTORISE'
'type'
gtycon
'='
gtycon
'#-}'
{ unitOL $ LL $
VectD (HsVectTypeIn False $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) }
|
annotation
{ unitOL $1 }
|
decl
{ unLoc $1 }
...
...
compiler/rename/RnSource.lhs
View file @
c439818a
...
...
@@ -664,6 +664,18 @@ rnHsVectDecl (HsVectTypeIn isScalar tycon (Just rhs_tycon))
}
rnHsVectDecl (HsVectTypeOut _ _ _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectTypeOut'"
rnHsVectDecl (HsVectClassIn cls)
= do { cls' <- lookupLocatedOccRn cls
; return (HsVectClassIn cls', unitFV (unLoc cls'))
}
rnHsVectDecl (HsVectClassOut _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
rnHsVectDecl (HsVectInstIn isScalar instTy)
= do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy
; return (HsVectInstIn isScalar instTy', emptyFVs)
}
rnHsVectDecl (HsVectInstOut _ _)
= panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
\end{code}
%*********************************************************
...
...
compiler/typecheck/TcBinds.lhs
View file @
c439818a
...
...
@@ -691,9 +691,9 @@ tcVect (HsNoVect name)
do { var <- wrapLocM tcLookupId name
; return $ HsNoVect var
}
tcVect (HsVectTypeIn isScalar lname
@(L _ name)
rhs_name)
tcVect (HsVectTypeIn isScalar lname rhs_name)
= addErrCtxt (vectCtxt lname) $
do { tycon <- tcLookupTyCon name
do { tycon <- tcLookup
Located
TyCon
l
name
; checkTc (not isScalar || tyConArity tycon == 0) scalarTyConMustBeNullary
; rhs_tycon <- fmapMaybeM (tcLookupTyCon . unLoc) rhs_name
...
...
@@ -701,9 +701,24 @@ tcVect (HsVectTypeIn isScalar lname@(L _ name) rhs_name)
}
tcVect (HsVectTypeOut _ _ _)
= panic "TcBinds.tcVect: Unexpected 'HsVectTypeOut'"
tcVect (HsVectClassIn lname)
= addErrCtxt (vectCtxt lname) $
do { cls <- tcLookupLocatedClass lname
; return $ HsVectClassOut cls
}
tcVect (HsVectClassOut _)
= panic "TcBinds.tcVect: Unexpected 'HsVectClassOut'"
tcVect (HsVectInstIn isScalar linstTy)
= addErrCtxt (vectCtxt linstTy) $
do { (cls, tys) <- tcHsVectInst linstTy
; inst <- tcLookupInstance cls tys
; return $ HsVectInstOut isScalar inst
}
tcVect (HsVectInstOut _ _)
= panic "TcBinds.tcVect: Unexpected 'HsVectInstOut'"
vectCtxt ::
Located Name
-> SDoc
vectCtxt
name
= ptext (sLit "When checking the vectorisation declaration for") <+> ppr
name
vectCtxt ::
Outputable thing => thing
-> SDoc
vectCtxt
thing
= ptext (sLit "When checking the vectorisation declaration for") <+> ppr
thing
scalarTyConMustBeNullary :: Message
scalarTyConMustBeNullary = ptext (sLit "VECTORISE SCALAR type constructor must be nullary")
...
...
compiler/typecheck/TcEnv.lhs
View file @
c439818a
...
...
@@ -17,7 +17,7 @@ module TcEnv(
tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupField, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
tcLookupLocatedClass,
tcLookupLocatedClass,
tcLookupInstance,
-- Local environment
tcExtendKindEnv, tcExtendKindEnvTvs,
...
...
@@ -78,6 +78,7 @@ import BasicTypes
import Outputable
import Unique
import FastString
import ListSetOps
\end{code}
...
...
@@ -171,6 +172,30 @@ tcLookupLocatedClass = addLocM tcLookupClass
tcLookupLocatedTyCon :: Located Name -> TcM TyCon
tcLookupLocatedTyCon = addLocM tcLookupTyCon
-- Find the instance that exactly matches a type class application. The class arguments must be precisely
-- the same as in the instance declaration (modulo renaming).
--
tcLookupInstance :: Class -> [Type] -> TcM Instance
tcLookupInstance cls tys
= do { instEnv <- tcGetInstEnvs
; case lookupUniqueInstEnv instEnv cls tys of
Left err -> failWithTc $ ptext (sLit "Couldn't match instance:") <+> err
Right (inst, tys)
| uniqueTyVars tys -> return inst
| otherwise -> failWithTc errNotExact
}
where
errNotExact = ptext (sLit "Not an exact match (i.e., some variables get instantiated)")
uniqueTyVars tys = all isTyVarTy tys && hasNoDups (map extractTyVar tys)
where
extractTyVar (TyVarTy tv) = tv
extractTyVar _ = panic "TcEnv.tcLookupInstance: extractTyVar"
tcGetInstEnvs = do { eps <- getEps; env <- getGblEnv;
; return (eps_inst_env eps, tcg_inst_env env)
}
\end{code}
\begin{code}
...
...
compiler/typecheck/TcHsSyn.lhs
View file @
c439818a
...
...
@@ -1034,6 +1034,12 @@ zonkVect env (HsNoVect v)
zonkVect _env (HsVectTypeOut s t rt)
= return $ HsVectTypeOut s t rt
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"
\end{code}
%************************************************************************
...
...
compiler/typecheck/TcHsType.lhs
View file @
c439818a
...
...
@@ -6,7 +6,7 @@
\begin{code}
module TcHsType (
tcHsSigType, tcHsSigTypeNC, tcHsDeriv,
tcHsSigType, tcHsSigTypeNC, tcHsDeriv,
tcHsVectInst,
tcHsInstHead, tcHsQuantifiedType,
UserTypeCtxt(..),
...
...
@@ -219,6 +219,20 @@ tc_hs_deriv tv_names ty
| otherwise
= failWithTc (ptext (sLit "Illegal deriving item") <+> ppr ty)
-- Used for 'VECTORISE [SCALAR] instance' declarations
--
tcHsVectInst :: LHsType Name -> TcM (Class, [Type])
tcHsVectInst ty
| Just (L _ cls_name, tys) <- splitLHsClassTy_maybe ty
= do { cls_kind <- kcClass cls_name
; (tys, _res_kind) <- kcApps cls_name cls_kind tys
; arg_tys <- dsHsTypes tys
; cls <- tcLookupClass cls_name
; return (cls, arg_tys)
}
| otherwise
= failWithTc $ ptext (sLit "Malformed instance type")
\end{code}
These functions are used during knot-tying in
...
...
compiler/typecheck/TcType.lhs
View file @
c439818a
...
...
@@ -26,7 +26,7 @@ module TcType (
UserTypeCtxt(..), pprUserTypeCtxt,
TcTyVarDetails(..), pprTcTyVarDetails, vanillaSkolemTv, superSkolemTv,
MetaDetails(Flexi, Indirect), MetaInfo(..),
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy,
isImmutableTyVar, isSkolemTyVar, isMetaTyVar, isMetaTyVarTy,
isTyVarTy,
isSigTyVar, isOverlappableTyVar, isTyConableTyVar,
isAmbiguousTyVar, metaTvRef,
isFlexi, isIndirect, isRuntimeUnkSkol,
...
...
compiler/types/InstEnv.lhs
View file @
c439818a
...
...
@@ -14,7 +14,7 @@ module InstEnv (
instanceDFunId, setInstanceDFunId, instanceRoughTcs,
InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv,
extendInstEnvList, lookupInstEnv', lookupInstEnv, instEnvElts,
extendInstEnvList,
lookupUniqueInstEnv,
lookupInstEnv', lookupInstEnv, instEnvElts,
classInstances, instanceBindFun,
instanceCantMatch, roughMatchTcs
) where
...
...
@@ -29,11 +29,13 @@ import TcType
import TyCon
import Unify
import Outputable
import ErrUtils
import BasicTypes
import UniqFM
import Id
import FastString
import Data.Data hiding (TyCon, mkTyConApp)
import Data.Maybe ( isJust, isNothing )
\end{code}
...
...
@@ -62,6 +64,7 @@ data Instance
, is_flag :: OverlapFlag -- See detailed comments with
-- the decl of BasicTypes.OverlapFlag
}
deriving (Data, Typeable)
\end{code}
Note [Rough-match field]
...
...
@@ -435,21 +438,41 @@ Note [InstTypes: instantiating types]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
A successful match is an Instance, together with the types at which
the dfun_id in the Instance should be instantiated
The instantiating types are (
Mabye
Type)s because the dfun
The instantiating types are (
Either TyVar
Type)s because the dfun
might have some tyvars that *only* appear in arguments
dfun :: forall a b. C a b, Ord b => D [a]
When we match this against D [ty], we return the instantiating types
[Right ty, Left b]
where the
Nothing
indicates that 'b' can be freely instantiated.
where the
'Left b'
indicates that 'b' can be freely instantiated.
(The caller instantiates it to a flexi type variable, which will
presumably later become fixed via functional dependencies.)
\begin{code}
-- |Look up an instance in the given instance environment. The given class application must match exactly
-- one instance and the match may not contain any flexi type variables. If the lookup is unsuccessful,
-- yield 'Left errorMessage'.
--
lookupUniqueInstEnv :: (InstEnv, InstEnv)
-> Class -> [Type]
-> Either Message (Instance, [Type])
lookupUniqueInstEnv instEnv cls tys
= case lookupInstEnv instEnv cls tys of
([(inst, inst_tys)], _, _)
| noFlexiVar -> Right (inst, inst_tys')
| otherwise -> Left $ ptext (sLit "flexible type variable:") <+>
(ppr $ mkTyConApp (classTyCon cls) tys)
where
inst_tys' = [ty | Right ty <- inst_tys]
noFlexiVar = all isRight inst_tys
_other -> Left $ ptext (sLit "instance not found") <+> (ppr $ mkTyConApp (classTyCon cls) tys)
where
isRight (Left _) = False
isRight (Right _) = True
lookupInstEnv' :: InstEnv -- InstEnv to look in
-> Class -> [Type] -- What we are looking for
-> ([InstMatch], -- Successful matches
[Instance]) -- These don't match but do unify
lookupInstEnv' :: InstEnv
-- InstEnv to look in
-> Class -> [Type] -- What we are looking for
-> ([InstMatch], -- Successful matches
[Instance]) -- These don't match but do unify
-- The second component of the result pair happens when we look up
-- Foo [a]
-- in an InstEnv that has entries for
...
...
compiler/vectorise/Vectorise.hs
View file @
c439818a
...
...
@@ -62,6 +62,8 @@ vectoriseIO hsc_env guts
--
vectModule
::
ModGuts
->
VM
ModGuts
vectModule
guts
@
(
ModGuts
{
mg_tcs
=
tycons
,
mg_clss
=
classes
,
mg_insts
=
insts
,
mg_binds
=
binds
,
mg_fam_insts
=
fam_insts
,
mg_vect_decls
=
vect_decls
...
...
@@ -75,16 +77,24 @@ vectModule guts@(ModGuts { mg_tcs = tycons
-- bindings for dfuns and family instances of the classes
-- 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
]
;
(
new_
tycons
,
new_fam_insts
,
tc_binds
)
<-
vectTypeEnv
tycons
[
vd
|
vd
@
(
VectType
_
_
_
)
<-
vect_decls
]
;
let
new_classes
=
[]
-- !!!FIXME
new_insts
=
[]
-- !!!we need to compute an extended 'mg_inst_env' as well!!!
-- Family instance environment for /all/ home-package modules including those instances
-- generated by 'vectTypeEnv'.
;
(
_
,
fam_inst_env
)
<-
readGEnv
global_fam_inst_env
-- Vectorise all the top level bindings and VECTORISE declarations on imported identifiers
;
binds_top
<-
mapM
vectTopBind
binds
;
binds_imp
<-
mapM
vectImpBind
[
imp_id
|
Vect
imp_id
_
<-
vect_decls
,
isGlobalId
imp_id
]
;
return
$
guts
{
mg_tcs
=
tycons'
;
return
$
guts
{
mg_tcs
=
tycons
++
new_tycons
,
mg_clss
=
classes
++
new_classes
,
mg_insts
=
insts
++
new_insts
,
mg_binds
=
Rec
tc_binds
:
(
binds_top
++
binds_imp
)
,
mg_fam_inst_env
=
fam_inst_env
,
mg_fam_insts
=
fam_insts
++
new_fam_insts
...
...
compiler/vectorise/Vectorise/Env.hs
View file @
c439818a
...
...
@@ -9,7 +9,6 @@ module Vectorise.Env (
GlobalEnv
(
..
),
initGlobalEnv
,
extendImportedVarsEnv
,
setFamEnv
,
extendFamEnv
,
extendTyConsEnv
,
setPAFunsEnv
,
...
...
@@ -159,13 +158,6 @@ extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv
extendImportedVarsEnv
ps
genv
=
genv
{
global_vars
=
extendVarEnvList
(
global_vars
genv
)
ps
}
-- |Set the list of type family instances in an environment.
--
setFamEnv
::
FamInstEnv
->
GlobalEnv
->
GlobalEnv
setFamEnv
l_fam_inst
genv
=
genv
{
global_fam_inst_env
=
(
g_fam_inst
,
l_fam_inst
)
}
where
(
g_fam_inst
,
_
)
=
global_fam_inst_env
genv
-- |Extend the list of type family instances.
--
extendFamEnv
::
[
FamInst
]
->
GlobalEnv
->
GlobalEnv
...
...
compiler/vectorise/Vectorise/Monad/Global.hs
View file @
c439818a
...
...
@@ -169,5 +169,3 @@ defTyConPAs ps = updGEnv $ \env ->
lookupTyConPR
::
TyCon
->
VM
(
Maybe
Var
)
lookupTyConPR
tc
=
readGEnv
$
\
env
->
lookupNameEnv
(
global_pr_funs
env
)
(
tyConName
tc
)
compiler/vectorise/Vectorise/Monad/InstEnv.hs
View file @
c439818a
...
...
@@ -19,16 +19,9 @@ import Outputable
#
include
"HsVersions.h"
getInstEnv
::
VM
(
InstEnv
,
InstEnv
)
getInstEnv
=
readGEnv
global_inst_env
getFamInstEnv
::
VM
FamInstEnvs
getFamInstEnv
=
readGEnv
global_fam_inst_env
-- Look up the dfun of a class instance.
--
-- The match must be unique
- ie
, match exactly one instance
-
but the
-- The match must be unique
—i.e.
, match exactly one instance
—
but the
-- type arguments used for matching may be more specific than those of
-- the class instance declaration. The found class instances must not have
-- any type variables in the instance context that do not appear in the
...
...
@@ -37,21 +30,11 @@ getFamInstEnv = readGEnv global_fam_inst_env
--
lookupInst
::
Class
->
[
Type
]
->
VM
(
DFunId
,
[
Type
])
lookupInst
cls
tys
=
do
{
instEnv
<-
getInstEnv
;
case
lookupInstEnv
instEnv
cls
tys
of
([(
inst
,
inst_tys
)],
_
,
_
)
|
noFlexiVar
->
return
(
instanceDFunId
inst
,
inst_tys'
)
|
otherwise
->
cantVectorise
"VectMonad.lookupInst: flexi var: "
(
ppr
$
mkTyConApp
(
classTyCon
cls
)
tys
)
where
inst_tys'
=
[
ty
|
Right
ty
<-
inst_tys
]
noFlexiVar
=
all
isRight
inst_tys
_other
->
cantVectorise
"VectMonad.lookupInst: not found "
(
ppr
cls
<+>
ppr
tys
)
=
do
{
instEnv
<-
readGEnv
global_inst_env
;
case
lookupUniqueInstEnv
instEnv
cls
tys
of
Right
(
inst
,
inst_tys
)
->
return
(
instanceDFunId
inst
,
inst_tys
)
Left
err
->
cantVectorise
"Vectorise.Monad.InstEnv.lookupInst:"
err
}
where
isRight
(
Left
_
)
=
False
isRight
(
Right
_
)
=
True
-- Look up the representation tycon of a family instance.
--
...
...
@@ -72,7 +55,7 @@ lookupInst cls tys
lookupFamInst
::
TyCon
->
[
Type
]
->
VM
(
TyCon
,
[
Type
])
lookupFamInst
tycon
tys
=
ASSERT
(
isFamilyTyCon
tycon
)
do
{
instEnv
<-
getFamI
nst
E
nv
do
{
instEnv
<-
readGEnv
global_fam_i
nst
_e
nv
;
case
lookupFamInstEnv
instEnv
tycon
tys
of
[(
fam_inst
,
rep_tys
)]
->
return
(
famInstTyCon
fam_inst
,
rep_tys
)
_other
->
...
...
compiler/vectorise/Vectorise/Type/Env.hs
View file @
c439818a
...
...
@@ -90,6 +90,11 @@ import Data.List
-- by the vectoriser).
--
-- Type constructors declared with {-# VECTORISE type T = T' #-} are treated in this manner.
--
-- In addition, we have also got a single pragma form for type classes: {-# VECTORISE class C #-}. It
-- implies that the class type constructor may be used in vectorised code together with its data
-- constructor. We generally produce a vectorised version of the data type and data constructor.
-- We do not generate 'PData' and 'PRepr' instances for class type constructors.
-- |Vectorise a type environment.
--
...
...
@@ -193,11 +198,9 @@ vectTypeEnv tycons vectTypeDecls
;
return
(
dfuns
,
binds
)
}
-- We return: (1) the vectorised type constructors, (2)
-- their 'PRepr' & 'PData' instance constructors two.
;
let
new_tycons
=
tycons
++
new_tcs
++
inst_tcs
;
return
(
new_tycons
,
fam_insts
,
binds
)
-- Return the vectorised variants of type constructors as well as the generated instance type
-- constructors, family instances, and dfun bindings.
;
return
(
new_tcs
++
inst_tcs
,
fam_insts
,
binds
)
}
...
...
compiler/vectorise/Vectorise/Utils/Base.hs
View file @
c439818a
...
...
@@ -15,7 +15,7 @@ module Vectorise.Utils.Base (
mkBuiltinCo
,
mkVScrut
,
preprSynTyCon
,
--
preprSynTyCon,
pdataReprTyCon
,
pdataReprDataCon
,
prDFunOfTyCon
...
...
@@ -122,18 +122,15 @@ mkPArray ty len dat = do
let
[
dc
]
=
tyConDataCons
tc
return
$
mkConApp
dc
[
Type
ty
,
len
,
dat
]
mkPDataType
::
Type
->
VM
Type
mkPDataType
ty
=
mkBuiltinTyConApp
pdataTyCon
[
ty
]
mkBuiltinCo
::
(
Builtins
->
TyCon
)
->
VM
Coercion
mkBuiltinCo
get_tc
=
do
tc
<-
builtin
get_tc
return
$
mkTyConAppCo
tc
[]
mkVScrut
::
VExpr
->
VM
(
CoreExpr
,
CoreExpr
,
TyCon
,
[
Type
])
mkVScrut
(
ve
,
le
)
=
do
...
...
@@ -142,13 +139,12 @@ mkVScrut (ve, le)
where
ty
=
exprType
ve
preprSynTyCon
::
Type
->
VM
(
TyCon
,
[
Type
])
preprSynTyCon
ty
=
builtin
preprTyCon
>>=
(`
lookupFamInst
`
[
ty
])
--
preprSynTyCon :: Type -> VM (TyCon, [Type])
--
preprSynTyCon ty = builtin preprTyCon >>= (`lookupFamInst` [ty])
pdataReprTyCon
::
Type
->
VM
(
TyCon
,
[
Type
])
pdataReprTyCon
ty
=
builtin
pdataTyCon
>>=
(`
lookupFamInst
`
[
ty
])
pdataReprDataCon
::
Type
->
VM
(
DataCon
,
[
Type
])
pdataReprDataCon
ty
=
do
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment