VECTORISE pragmas for type classes and instances

* Frontend support (not yet used in the vectoriser)

6 files changed, 30 insertions, 48 deletions

diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index daa2ed0725..aad504fc7d 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/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
diff --git a/compiler/vectorise/Vectorise/Env.hs b/compiler/vectorise/Vectorise/Env.hs
index 465d58c54a..5597a2d9a7 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/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
diff --git a/compiler/vectorise/Vectorise/Monad/Global.hs b/compiler/vectorise/Vectorise/Monad/Global.hs
index 5639c238e3..c0dc97e403 100644
--- a/compiler/vectorise/Vectorise/Monad/Global.hs
+++ b/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)
-
-
diff --git a/compiler/vectorise/Vectorise/Monad/InstEnv.hs b/compiler/vectorise/Vectorise/Monad/InstEnv.hs
index be149af9d7..c36f179229 100644
--- a/compiler/vectorise/Vectorise/Monad/InstEnv.hs
+++ b/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                -> 
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index a91acab69d..7457356208 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/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)
        }
 
 
diff --git a/compiler/vectorise/Vectorise/Utils/Base.hs b/compiler/vectorise/Vectorise/Utils/Base.hs
index e87c7ca96f..cea4749839 100644
--- a/compiler/vectorise/Vectorise/Utils/Base.hs
+++ b/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