Commit c439818a authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.

VECTORISE pragmas for type classes and instances

* Frontend support (not yet used in the vectoriser)
parent f05b36dc
......@@ -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
......
......@@ -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
......
......@@ -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}
......
......@@ -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}
......@@ -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}
......@@ -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}
%************************************************************************
......
......@@ -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 }
......
......@@ -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}
%*********************************************************
......
......@@ -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 <- tcLookupLocatedTyCon lname
; 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")
......
......@@ -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}
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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,
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -169,5 +169,3 @@ defTyConPAs ps = updGEnv $ \env ->
lookupTyConPR :: TyCon -> VM (Maybe Var)
lookupTyConPR tc = readGEnv $ \env -> lookupNameEnv (global_pr_funs env) (tyConName tc)
......@@ -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 <- getFamInstEnv
do { instEnv <- readGEnv global_fam_inst_env
; case lookupFamInstEnv instEnv tycon tys of
[(fam_inst, rep_tys)] -> return (famInstTyCon fam_inst, rep_tys)
_other ->
......
......@@ -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)
}
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment