VECTORISE pragmas for type classes and instances

* Frontend support (not yet used in the vectoriser)

compiler/basicTypes/BasicTypes.lhs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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")

compiler/typecheck/TcEnv.lhs

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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                -> 

compiler/vectorise/Vectorise/Type/Env.hs

@@ -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

@@ -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