Clean up and complete the vectorisation of type classes

13 files changed, 265 insertions, 203 deletions

diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index def9bba9e4..0df37e4300 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -597,14 +597,14 @@ mkDataCOcc = mk_simple_deriv varName  "$c"
 -- Vectorisation
 mkVectOcc, mkVectTyConOcc, mkVectDataConOcc, mkVectIsoOcc, mkPADFunOcc, mkPReprTyConOcc,
   mkPDataTyConOcc, mkPDataDataConOcc :: Maybe String -> OccName -> OccName
-mkVectOcc         = mk_simple_deriv_with varName  "$v_"
-mkVectTyConOcc    = mk_simple_deriv_with tcName   ":V_"
-mkVectDataConOcc  = mk_simple_deriv_with dataName ":VD_"
-mkVectIsoOcc      = mk_simple_deriv_with varName  "$VI_"
-mkPADFunOcc       = mk_simple_deriv_with varName  "$PA_"
-mkPReprTyConOcc   = mk_simple_deriv_with tcName   ":VR_"
-mkPDataTyConOcc   = mk_simple_deriv_with tcName   ":VP_"
-mkPDataDataConOcc = mk_simple_deriv_with dataName ":VPD_"
+mkVectOcc         = mk_simple_deriv_with varName  "$v"
+mkVectTyConOcc    = mk_simple_deriv_with tcName   "V:"
+mkVectDataConOcc  = mk_simple_deriv_with dataName "VD:"
+mkVectIsoOcc      = mk_simple_deriv_with varName  "$vi"
+mkPADFunOcc       = mk_simple_deriv_with varName  "$pa"
+mkPReprTyConOcc   = mk_simple_deriv_with tcName   "VR:"
+mkPDataTyConOcc   = mk_simple_deriv_with tcName   "VP:"
+mkPDataDataConOcc = mk_simple_deriv_with dataName "VPD:"
 
 mk_simple_deriv :: NameSpace -> String -> OccName -> OccName
 mk_simple_deriv sp px occ = mk_deriv sp px (occNameString occ)
diff --git a/compiler/coreSyn/CoreFVs.lhs b/compiler/coreSyn/CoreFVs.lhs
index 85c23aeb32..4eaf965cc8 100644
--- a/compiler/coreSyn/CoreFVs.lhs
+++ b/compiler/coreSyn/CoreFVs.lhs
@@ -339,6 +339,8 @@ vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet
     vectFreeVars (Vect   _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet
     vectFreeVars (NoVect _)            = noFVs
     vectFreeVars (VectType _ _ _)      = noFVs
+    vectFreeVars (VectClass _)         = noFVs
+    vectFreeVars (VectInst _ _)        = noFVs
       -- this function is only concerned with values, not types
 \end{code}
 
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index 87f3343f94..603364a6b9 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -401,7 +401,7 @@ lookupDAPPRdrEnv occ
            _     -> pprPanic "Multiple definitions in 'Data.Array.Parallel.Prim':" (ppr occ)
        }
 
--- Find the thing repferred to by an imported name.
+-- Find the thing referred to by an imported name.
 --
 dsImportDecl :: Name -> DsM TyThing
 dsImportDecl name
diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs
index cc95762312..118562d542 100644
--- a/compiler/iface/LoadIface.lhs
+++ b/compiler/iface/LoadIface.lhs
@@ -250,8 +250,7 @@ loadInterface doc_str mod from
         ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface)
         ; new_eps_rules     <- tcIfaceRules ignore_prags (mi_rules iface)
         ; new_eps_anns      <- tcIfaceAnnotations (mi_anns iface)
-        ; new_eps_vect_info <- tcIfaceVectInfo mod (mkNameEnv new_eps_decls) 
-                                               (mi_vect_info iface)
+        ; new_eps_vect_info <- tcIfaceVectInfo mod (mi_vect_info iface)
 
         ; let { final_iface = iface {   
                                 mi_decls     = panic "No mi_decls in PIT",
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 04b9147717..a11051b65f 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -273,8 +273,7 @@ typecheckIface iface
         ; anns      <- tcIfaceAnnotations (mi_anns iface)
 
                 -- Vectorisation information
-        ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env 
-                                       (mi_vect_info iface)
+        ; vect_info <- tcIfaceVectInfo (mi_module iface) (mi_vect_info iface)
 
                 -- Exports
         ; exports <- ifaceExportNames (mi_exports iface)
@@ -711,53 +710,64 @@ tcIfaceAnnTarget (ModuleTarget mod) = do
 %************************************************************************
 
 \begin{code}
-tcIfaceVectInfo :: Module -> TypeEnv  -> IfaceVectInfo -> IfL VectInfo
-tcIfaceVectInfo mod typeEnv (IfaceVectInfo 
-                             { ifaceVectInfoVar          = vars
-                             , ifaceVectInfoTyCon        = tycons
-                             , ifaceVectInfoTyConReuse   = tyconsReuse
-                             , ifaceVectInfoScalarVars   = scalarVars
-                             , ifaceVectInfoScalarTyCons = scalarTyCons
-                             })
+tcIfaceVectInfo :: Module -> IfaceVectInfo -> IfL VectInfo
+tcIfaceVectInfo mod (IfaceVectInfo 
+                     { ifaceVectInfoVar          = vars
+                     , ifaceVectInfoTyCon        = tycons
+                     , ifaceVectInfoTyConReuse   = tyconsReuse
+                     , ifaceVectInfoScalarVars   = scalarVars
+                     , ifaceVectInfoScalarTyCons = scalarTyCons
+                     })
   = do { let scalarTyConsSet = mkNameSet scalarTyCons
-       ; vVars     <- mapM vectVarMapping                          vars
-       ; tyConRes1 <- mapM vectTyConMapping                        tycons
-       ; tyConRes2 <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse
+       ; vVars       <- mapM vectVarMapping                          vars
+       ; tyConRes1   <- mapM vectTyConMapping                        tycons
+       ; tyConRes2   <- mapM (vectTyConReuseMapping scalarTyConsSet) tyconsReuse
+       ; vScalarVars <- mapM vectVar                                 scalarVars
        ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2)
        ; return $ VectInfo 
                   { vectInfoVar          = mkVarEnv  vVars
                   , vectInfoTyCon        = mkNameEnv vTyCons
                   , vectInfoDataCon      = mkNameEnv (concat vDataCons)
-                  , vectInfoScalarVars   = mkVarSet  (map lookupVar scalarVars)
+                  , vectInfoScalarVars   = mkVarSet  vScalarVars
                   , vectInfoScalarTyCons = scalarTyConsSet
                   }
        }
   where
     vectVarMapping name 
       = do { vName <- lookupOrig mod (mkLocalisedOccName mod mkVectOcc name)
-           ; var  <- forkM (ptext (sLit "vect var")  <+> ppr name)  $
-                     tcIfaceExtId name
-           ; vVar <- forkM (ptext (sLit "vect vVar [mod =") <+> 
-                            ppr mod <> ptext (sLit "; nameModule =") <+> 
-                            ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
-                     tcIfaceExtId vName
+           ; var   <- forkM (ptext (sLit "vect var")  <+> ppr name)  $
+                        tcIfaceExtId name
+           ; vVar  <- forkM (ptext (sLit "vect vVar [mod =") <+> 
+                             ppr mod <> ptext (sLit "; nameModule =") <+> 
+                             ppr (nameModule name) <> ptext (sLit "]") <+> ppr vName) $
+                       tcIfaceExtId vName
            ; return (var, (var, vVar))
            }
+
+    vectVar name 
+      = forkM (ptext (sLit "vect scalar var")  <+> ppr name)  $
+          tcIfaceExtId name
+
     vectTyConMapping name 
-      = do { vName   <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
-           -- FIXME: we will need to use tcIfaceTyCon/tcIfaceExtId on some of these (but depends
-           --   on how we exactly define the 'VECTORISE type' pragma to work)
-           ; let { tycon    = lookupTyCon name
-                 ; vTycon   = lookupTyCon vName
-                 }
-           ; vDataCons <- mapM vectDataConMapping (tyConDataCons tycon)
+      = do { vName  <- lookupOrig mod (mkLocalisedOccName mod mkVectTyConOcc name)
+           ; tycon  <- forkM (text ("vect tycon") <+> ppr name) $
+                         tcIfaceTyCon (IfaceTc name)
+           ; vTycon <- forkM (text ("vect vTycon") <+> ppr vName) $
+                         tcIfaceTyCon (IfaceTc vName)
+
+               -- we need to handle class type constructors differently due to the manner in which
+               -- the name for the dictionary data constructor is computed
+           ; vDataCons <- if isClassTyCon tycon
+                          then vectClassDataConMapping vName (tyConSingleDataCon_maybe tycon)
+                          else mapM vectDataConMapping (tyConDataCons tycon)
            ; return ( (name, (tycon, vTycon))          -- (T, T_v)
                     , vDataCons                        -- list of (Ci, Ci_v)
                     )
            }
+
     vectTyConReuseMapping scalarNames name 
       = do { tycon <- forkM (text ("vect reuse tycon") <+> ppr name) $
-                      tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
+                        tcIfaceTyCon (IfaceTc name) -- somewhat naughty for wired in tycons, but ok
            ; if name `elemNameSet` scalarNames
              then do
            { return ( (name, (tycon, tycon))      -- scalar type constructors expose no data..
@@ -772,31 +782,23 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
                     , vDataCons                       -- list of (Ci, Ci)
                     )
            }}
+
+    vectClassDataConMapping _vTyconName Nothing = panic "tcIfaceVectInfo: vectClassDataConMapping"
+    vectClassDataConMapping vTyconName  (Just datacon)
+      = do { let name = dataConName datacon
+           ; vName <- lookupOrig mod (mkClassDataConOcc . nameOccName $ vTyconName)
+           ; vDataCon <- forkM (text ("vect class datacon") <+> ppr name) $
+                           tcIfaceDataCon vName
+           ; return [(name, (datacon, vDataCon))]
+           }
+
     vectDataConMapping datacon
       = do { let name = dataConName datacon
            ; vName <- lookupOrig mod (mkLocalisedOccName mod mkVectDataConOcc name)
-           ; let vDataCon = lookupDataCon vName
+           ; vDataCon <- forkM (text ("vect datacon") <+> ppr name) $
+                           tcIfaceDataCon vName
            ; return (name, (datacon, vDataCon))
            }
-    --
-    lookupVar name = case lookupTypeEnv typeEnv name of
-                       Just (AnId var) -> var
-                       Just _         -> 
-                         pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
-                       Nothing        ->
-                         pprPanic "TcIface.tcIfaceVectInfo: unknown name of id" (ppr name)
-    lookupTyCon name = case lookupTypeEnv typeEnv name of
-                         Just (ATyCon tc) -> tc
-                         Just _         -> 
-                           pprPanic "TcIface.tcIfaceVectInfo: not a tycon" (ppr name)
-                         Nothing        ->
-                           pprPanic "TcIface.tcIfaceVectInfo: unknown name of tycon" (ppr name)
-    lookupDataCon name = case lookupTypeEnv typeEnv name of
-                           Just (ADataCon dc) -> dc
-                           Just _         -> 
-                             pprPanic "TcIface.tcIfaceVectInfo: not a datacon" (ppr name)
-                           Nothing        ->
-                             pprPanic "TcIface.tcIfaceVectInfo: unknown name of datacon" (ppr name)
 \end{code}
 
 %************************************************************************
diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot
index a9684a6a91..fd2b647046 100644
--- a/compiler/iface/TcIface.lhs-boot
+++ b/compiler/iface/TcIface.lhs-boot
@@ -7,13 +7,13 @@ import TcRnTypes   ( IfL )
 import InstEnv     ( Instance )
 import FamInstEnv  ( FamInst )
 import CoreSyn     ( CoreRule )
-import HscTypes    ( TypeEnv, VectInfo, IfaceVectInfo )
+import HscTypes    ( VectInfo, IfaceVectInfo )
 import Module      ( Module )
 import Annotations ( Annotation )
 
 tcIfaceDecl        :: Bool -> IfaceDecl -> IfL TyThing
 tcIfaceRules       :: Bool -> [IfaceRule] -> IfL [CoreRule]
-tcIfaceVectInfo    :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo
+tcIfaceVectInfo    :: Module -> IfaceVectInfo -> IfL VectInfo
 tcIfaceInst        :: IfaceInst -> IfL Instance
 tcIfaceFamInst     :: IfaceFamInst -> IfL FamInst
 tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation]
diff --git a/compiler/vectorise/Vectorise.hs b/compiler/vectorise/Vectorise.hs
index aad504fc7d..3ba247dfbe 100644
--- a/compiler/vectorise/Vectorise.hs
+++ b/compiler/vectorise/Vectorise.hs
@@ -62,8 +62,6 @@ 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
@@ -71,18 +69,29 @@ vectModule guts@(ModGuts { mg_tcs        = tycons
  = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ 
           pprCoreBindings binds
  
+          -- Pick out all 'VECTORISE type' and 'VECTORISE class' pragmas
+      ; let ty_vect_decls  = [vd | vd@(VectType _ _ _) <- vect_decls]
+            cls_vect_decls = [vd | vd@(VectClass _)    <- vect_decls]
+      
           -- Vectorise the type environment.  This will add vectorised
           -- type constructors, their representaions, and the
           -- conrresponding data constructors.  Moreover, we produce
           -- bindings for dfuns and family instances of the classes
           -- and type families used in the DPH library to represent
           -- array types.
-      ; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons [vd
-                                                                    | vd@(VectType _ _ _) <- vect_decls]
+      ; (new_tycons, new_fam_insts, tc_binds) <- vectTypeEnv tycons ty_vect_decls cls_vect_decls
+
+{- TODO:
+
+instance Num Int where
+  (+) = primAdd
+{-# VECTORISE SCALAR instance Num Int #-}
 
-      ; let new_classes = []  -- !!!FIXME
-            new_insts   = []
-            -- !!!we need to compute an extended 'mg_inst_env' as well!!!
+==> $dNumInt :: Num Int; $dNumInt = Num primAdd
+=>> $v$dNumInt :: $vNum Int
+    $v$dNumInt = $vNum (closure1 (scalar_zipWith primAdd) (scalar_zipWith primAdd))
+  $dNumInt -v> $v$dNumInt
+-}
 
           -- Family instance environment for /all/ home-package modules including those instances
           -- generated by 'vectTypeEnv'.
@@ -93,8 +102,8 @@ vectModule guts@(ModGuts { mg_tcs        = tycons
       ; binds_imp <- mapM vectImpBind [imp_id | Vect imp_id _ <- vect_decls, isGlobalId imp_id]
 
       ; return $ guts { mg_tcs          = tycons ++ new_tycons
-                      , mg_clss         = classes ++ new_classes
-                      , mg_insts        = insts ++ new_insts
+                        -- we produce no new classes or instances, only new class type constructors
+                        -- and dfuns
                       , 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 5597a2d9a7..2f20bb4067 100644
--- a/compiler/vectorise/Vectorise/Env.hs
+++ b/compiler/vectorise/Vectorise/Env.hs
@@ -198,7 +198,8 @@ modVectInfo env mg_ids mg_tyCons vectDecls info
     }
   where
     vectIds        = [id    | Vect     id    _   <- vectDecls]
-    vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls]
+    vectTypeTyCons = [tycon | VectType _ tycon _ <- vectDecls] ++
+                     [tycon | VectClass tycon    <- vectDecls]
     vectDataCons   = concatMap tyConDataCons vectTypeTyCons
     ids            = mg_ids ++ vectIds
     tyCons         = mg_tyCons ++ vectTypeTyCons
diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index eaf0c1f183..a7d984cf83 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -85,8 +85,8 @@ initV hsc_env guts info thing_inside
            ; eps <- liftIO $ hscEPS hsc_env
            ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts)
                  instEnvs    = (eps_inst_env     eps, mg_inst_env     guts)
-                 builtin_pas = initClassDicts instEnvs (paClass builtins) -- grab all available 'PA' and..
-                 builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances
+                 builtin_pas = initClassDicts instEnvs (paClass builtins)  -- grab all 'PA' and..
+                 builtin_prs = initClassDicts instEnvs (prClass builtins)  -- ..'PR' class instances
 
                -- construct the initial global environment
            ; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside
@@ -110,9 +110,9 @@ initV hsc_env guts info thing_inside
 
     new_info genv = modVectInfo genv ids (mg_tcs guts) (mg_vect_decls guts) info
 
-    -- For a given DPH class, produce a mapping from type constructor (in head position) to the instance
-    -- dfun for that type constructor and class.  (DPH class instances cannot overlap in head
-    -- constructors.)
+    -- For a given DPH class, produce a mapping from type constructor (in head position) to the
+    -- instance dfun for that type constructor and class.  (DPH class instances cannot overlap in
+    -- head constructors.)
     --
     initClassDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)]
     initClassDicts insts cls = map find $ classInstances insts cls
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
index 5bf768310c..1a0a434adc 100644
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ b/compiler/vectorise/Vectorise/Type/Classify.hs
@@ -26,7 +26,7 @@ import Type
 import Digraph
 
 
--- |From a list of type constructors, extract those thatcan be vectorised, returning them in two
+-- |From a list of type constructors, extract those that can be vectorised, returning them in two
 -- sets, where the first result list /must be/ vectorised and the second result list /need not be/
 -- vectroised.
 
@@ -55,7 +55,11 @@ classifyTyCons convStatus tcs = classify [] [] convStatus (tyConGroups tcs)
         can_convert  = isNullUFM (refs `minusUFM` cs) && all convertable tcs
         must_convert = foldUFM (||) False (intersectUFM_C const cs refs)
 
-        convertable tc = isDataTyCon tc && all isVanillaDataCon (tyConDataCons tc)
+        -- We currently admit Haskell 2011-style data and newtype declarations as well as type
+        -- constructors representing classes.
+        convertable tc 
+          = (isDataTyCon tc || isNewTyCon tc) && all isVanillaDataCon (tyConDataCons tc)
+            || isClassTyCon tc
 
 -- Used to group type constructors into mutually dependent groups.
 --
diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs
index 7457356208..2373bcaf00 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -1,10 +1,7 @@
-{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
-
--- Vectorise a modules type environment, the structure containing all type things defined in a
--- module.
+-- Vectorise a modules type and class declarations.
 --
--- This extends the type environment with vectorised variants of data types and produces value
--- bindings for worker functions and the like.
+-- This produces new type constructors and family instances top be included in the module toplevel
+-- as well as bindings for worker functions, dfuns, and the like.
 
 module Vectorise.Type.Env ( 
   vectTypeEnv,
@@ -91,19 +88,47 @@ import Data.List
 --
 --     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
+-- 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.
+-- We do not generate 'PData' and 'PRepr' instances for class type constructors.  This pragma is the
+-- default for all type classes declared in this module, but the pragma can also be used explitly on
+-- imported classes.
+
+-- Note [Vectorising classes]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
+-- We vectorise classes essentially by just vectorising their desugared Core representation, but we
+-- do generate a 'Class' structure along the way (see 'Vectorise.Type.TyConDecl.vectTyConDecl').
+--
+-- Here is an example illustrating the mapping — assume
+--
+--   class Num a where
+--     (+) :: a -> a -> a
+--
+-- It desugars to
+--
+--   data Num a = Num { (+) :: a -> a -> a }
+--
+-- which we vectorise to
+--
+--  data $vNum a = $vNum { ($v+) :: PArray a :-> PArray a :-> PArray a }
+--
+-- while adding the following entries to the vectorisation map:
+--
+--   tycon  : Num --> $vNum
+--   datacon: Num --> $vNum
+--   var    : (+) --> ($v+)
 
--- |Vectorise a type environment.
+-- |Vectorise type constructor including class type constructors.
 --
-vectTypeEnv :: [TyCon]                  -- TyCons defined in this module
+vectTypeEnv :: [TyCon]                  -- Type constructors defined in this module
             -> [CoreVect]               -- All 'VECTORISE [SCALAR] type' declarations in this module
+            -> [CoreVect]               -- All 'VECTORISE class' declarations in this module
             -> VM ( [TyCon]             -- old TyCons ++ new TyCons
                   , [FamInst]           -- New type family instances.
                   , [(Var, CoreExpr)])  -- New top level bindings.
-vectTypeEnv tycons vectTypeDecls
+vectTypeEnv tycons vectTypeDecls vectClassDecls
   = do { traceVt "** vectTypeEnv" $ ppr tycons
 
          -- Build a map containing all vectorised type constructor.  If they are scalar, they are
@@ -118,7 +143,8 @@ vectTypeEnv tycons vectTypeDecls
              localScalarTyCons      = [tycon | VectType True  tycon Nothing <- vectTypeDecls]
 
                -- {-# VECTORISE type T -#} (ONLY the imported tycons)
-             impVectTyCons          = [tycon | VectType False tycon Nothing <- vectTypeDecls]
+             impVectTyCons          = (   [tycon | VectType False tycon Nothing <- vectTypeDecls]
+                                       ++ [tycon | VectClass tycon              <- vectClassDecls])
                                       \\ tycons
 
                -- {-# VECTORISE type T = ty -#} (imported and local tycons)
@@ -141,7 +167,9 @@ vectTypeEnv tycons vectTypeDecls
              orig_tcs               = keep_tcs ++ conv_tcs
              
        ; traceVt " VECT SCALAR    : " $ ppr localScalarTyCons
+       ; traceVt " VECT [class]   : " $ ppr impVectTyCons
        ; traceVt " VECT with rhs  : " $ ppr (map fst vectTyConsWithRHS)
+       ; traceVt " -- after classification (local and VECT [class] tycons) --" empty
        ; traceVt " reuse          : " $ ppr keep_tcs
        ; traceVt " convert        : " $ ppr conv_tcs
 
@@ -164,7 +192,8 @@ vectTypeEnv tycons vectTypeDecls
            -- "Note [Pragmas to vectorise tycons]".
        ; mapM_ (uncurry defTyConDataCons) vectTyConsWithRHS
 
-           -- Vectorise all the data type declarations that we can and must vectorise.
+           -- Vectorise all the data type declarations that we can and must vectorise (enter the
+           -- type and data constructors into the vectorisation map on-the-fly.)
        ; new_tcs <- vectTyConDecls conv_tcs
 
            -- We don't need new representation types for dictionary constructors. The constructors
@@ -198,8 +227,8 @@ vectTypeEnv tycons vectTypeDecls
               ; return (dfuns, binds)
               }
 
-           -- Return the vectorised variants of type constructors as well as the generated instance type
-           -- constructors, family instances, and dfun bindings.
+           -- 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/Type/TyConDecl.hs b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
index c4308e433f..600afd2c24 100644
--- a/compiler/vectorise/Vectorise/Type/TyConDecl.hs
+++ b/compiler/vectorise/Vectorise/Type/TyConDecl.hs
@@ -21,81 +21,92 @@ import Control.Monad
 --
 vectTyConDecls :: [TyCon] -> VM [TyCon]
 vectTyConDecls tcs = fixV $ \tcs' ->
-  do
-    mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
-    mapM vectTyConDecl tcs
+  do { mapM_ (uncurry defTyCon) (zipLazy tcs tcs')
+     ; mapM vectTyConDecl tcs
+     }
 
 -- |Vectorise a single type constructor.
 --
 vectTyConDecl :: TyCon -> VM TyCon
 vectTyConDecl tycon
-  -- a type class constructor.
-  -- TODO: check for no stupid theta, fds, assoc types. 
-  | isClassTyCon tycon
-  , Just cls		<- tyConClass_maybe tycon
-
-  = do  -- make the name of the vectorised class tycon.
-        name'       <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
-
-        -- vectorise right of definition.
-        rhs'        <- vectAlgTyConRhs tycon (algTyConRhs tycon)
-
-        -- vectorise method selectors.
-        -- This also adds a mapping between the original and vectorised method selector
-        -- to the state.
-        methods'    <- mapM vectMethod
-                    $  [(id, defMethSpecOfDefMeth meth) 
-                            | (id, meth)    <- classOpItems cls]
-
-        -- keep the original recursiveness flag.
-        let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
-  
-        -- Calling buildclass here attaches new quantifiers and dictionaries to the method types.
-        cls'     <- liftDs 
-                $  buildClass
-                         False               -- include unfoldings on dictionary selectors.
-                         name'               -- new name  V_T:Class
-                         (tyConTyVars tycon) -- keep original type vars
-                         []                  -- no stupid theta
-                         []                  -- no functional dependencies
-                         []                  -- no associated types
-                         methods'            -- method info
-                         rec_flag            -- whether recursive
-
-        let tycon'  = mkClassTyCon name'
-                         (tyConKind tycon)
-                         (tyConTyVars tycon)
-                         rhs'
-                         cls'
-                         rec_flag
-
-        return $ tycon'
+
+      -- Type constructor representing a type class
+  | Just cls <- tyConClass_maybe tycon
+  = do { unless (null $ classATs cls) $
+           cantVectorise "Associated types are not yet supported" (ppr cls)
+
+           -- make the name of the vectorised class tycon: "Class" --> "V:Class"
+       ; name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
+       
+           -- vectorise superclass constraint (types)
+       ; theta' <- mapM vectType (classSCTheta cls)
+
+           -- vectorise method selectors and add them to the vectorisation map
+       ; methods' <- sequence [ vectMethod id meth | (id, meth) <- classOpItems cls]
+
+           -- keep the original recursiveness flag
+       ; let rec_flag = boolToRecFlag (isRecursiveTyCon tycon)
+
+           -- construct the vectorised class (this also creates the class type constructors and its
+           -- data constructor)
+           --
+           -- NB: 'buildClass' attaches new quantifiers and dictionaries to the method types
+       ; cls' <- liftDs $
+                   buildClass
+                     False                      -- include unfoldings on dictionary selectors
+                     name'                      -- new name: "V:Class"
+                     (tyConTyVars tycon)        -- keep original type vars
+                     theta'                     -- superclasses
+                     (snd . classTvsFds $ cls)  -- keep the original functional dependencies
+                     []                         -- no associated types (for the moment)
+                     methods'                   -- method info
+                     rec_flag                   -- whether recursive
+
+           -- the original dictionary constructor must map to the vectorised one
+       ; let tycon'        = classTyCon cls'
+             Just datacon  = tyConSingleDataCon_maybe tycon
+             Just datacon' = tyConSingleDataCon_maybe tycon'
+       ; defDataCon datacon datacon'
+
+           -- return the type constructor of the vectorised class
+       ; return tycon'
+       }
                       
-  -- a regular algebraic type constructor.
-  -- TODO: check for stupid theta, generaics, GADTS etc
+       -- Regular algebraic type constructor — for now, Haskell 2011-style only
   | isAlgTyCon tycon
-  = do  name'       <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
-        rhs'        <- vectAlgTyConRhs tycon (algTyConRhs tycon)
-        let rec_flag =  boolToRecFlag (isRecursiveTyCon tycon)
-
-        liftDs $ buildAlgTyCon 
-                        name'               -- new name
-                        (tyConTyVars tycon) -- keep original type vars.
-                        []                  -- no stupid theta.
-                        rhs'                -- new constructor defs.
-                        rec_flag            -- FIXME: is this ok?
-                        False               -- not GADT syntax
-                        NoParentTyCon
-                        Nothing             -- not a family instance
-
-    -- some other crazy thing that we don't handle.
-    | otherwise
-    = cantVectorise "Can't vectorise type constructor: " (ppr tycon)
-
-
--- | Vectorise a class method.
-vectMethod :: (Id, DefMethSpec) -> VM (Name, DefMethSpec, Type)
-vectMethod (id, defMeth)
+  = do { unless (all isVanillaDataCon (tyConDataCons tycon)) $
+           cantVectorise "Currently only Haskell 2011 datatypes are supported" (ppr tycon)
+  
+           -- make the name of the vectorised class tycon
+       ; name' <- mkLocalisedName mkVectTyConOcc (tyConName tycon)
+
+           -- vectorise the data constructor of the class tycon
+       ; rhs' <- vectAlgTyConRhs tycon (algTyConRhs tycon)
+
+           -- keep the original recursiveness and GADT flags
+       ; let rec_flag  = boolToRecFlag (isRecursiveTyCon tycon)
+             gadt_flag = isGadtSyntaxTyCon tycon
+
+           -- build the vectorised type constructor
+       ; liftDs $ buildAlgTyCon 
+                    name'                   -- new name
+                    (tyConTyVars tycon)     -- keep original type vars
+                    []                      -- no stupid theta
+                    rhs'                    -- new constructor defs
+                    rec_flag                -- whether recursive
+                    gadt_flag               -- whether in GADT syntax
+                    NoParentTyCon           
+                    Nothing                 -- not a family instance
+       }
+
+  -- some other crazy thing that we don't handle
+  | otherwise
+  = cantVectorise "Can't vectorise exotic type constructor" (ppr tycon)
+
+-- |Vectorise a class method.
+--
+vectMethod :: Id -> DefMeth -> VM (Name, DefMethSpec, Type)
+vectMethod id defMeth
  = do {   -- Vectorise the method type.
       ; typ' <- vectType (varType id)
 
@@ -110,56 +121,62 @@ vectMethod (id, defMeth)
       ; let (_tyvars, tyBody) = splitForAllTys typ'
       ; let (_dict,   tyRest) = splitFunTy tyBody
 
-      ; return  (Var.varName id', defMeth, tyRest)
+      ; return  (Var.varName id', defMethSpecOfDefMeth defMeth, tyRest)
       }
 
 -- |Vectorise the RHS of an algebraic type.
 --
 vectAlgTyConRhs :: TyCon -> AlgTyConRhs -> VM AlgTyConRhs
-vectAlgTyConRhs _ (DataTyCon { data_cons = data_cons
-                             , is_enum   = is_enum
-                             })
-  = do
-      data_cons' <- mapM vectDataCon data_cons
-      zipWithM_ defDataCon data_cons data_cons'
-      return $ DataTyCon { data_cons = data_cons'
-                         , is_enum   = is_enum
-                         }
-vectAlgTyConRhs tc _ 
-        = cantVectorise "Can't vectorise type definition:" (ppr tc)
-
--- |Vectorise a data constructor.
---
--- Vectorises its argument and return types.
+vectAlgTyConRhs tc (AbstractTyCon {})
+  = cantVectorise "Can't vectorise imported abstract type" (ppr tc)
+vectAlgTyConRhs _tc DataFamilyTyCon
+  = return DataFamilyTyCon
+vectAlgTyConRhs _tc (DataTyCon { data_cons = data_cons
+                               , is_enum   = is_enum
+                               })
+  = do { data_cons' <- mapM vectDataCon data_cons
+       ; zipWithM_ defDataCon data_cons data_cons'
+       ; return $ DataTyCon { data_cons = data_cons'
+                            , is_enum   = is_enum
+                            }
+       }
+vectAlgTyConRhs tc (NewTyCon {})
+  = cantVectorise noNewtypeErr (ppr tc)
+  where
+    noNewtypeErr = "Vectorisation of newtypes not supported yet; please use a 'data' declaration"
+
+-- |Vectorise a data constructor by vectorising its argument and return types..
 --
 vectDataCon :: DataCon -> VM DataCon
 vectDataCon dc
-  | not . null $ dataConExTyVars dc
-  = cantVectorise "Can't vectorise constructor (existentials):" (ppr dc)
-
-  | not . null $ dataConEqSpec   dc
-  = cantVectorise "Can't vectorise constructor (eq spec):" (ppr dc)
-
+  | not . null $ ex_tvs
+  = cantVectorise "Can't vectorise constructor with existential type variables yet" (ppr dc)
+  | not . null $ eq_spec
+  = cantVectorise "Can't vectorise constructor with equality context yet" (ppr dc)
+  | not . null $ dataConFieldLabels dc
+  = cantVectorise "Can't vectorise constructor with labelled fields yet" (ppr dc)
+  | not . null $ theta
+  = cantVectorise "Can't vectorise constructor with constraint context yet" (ppr dc)
   | otherwise
-  = do
-      name'    <- mkLocalisedName mkVectDataConOcc name
-      tycon'   <- vectTyCon tycon
-      arg_tys  <- mapM vectType rep_arg_tys
-
-      liftDs $ buildDataCon 
-                name'
-                False                          -- not infix
-                (map (const HsNoBang) arg_tys) -- strictness annots on args.
-                []                             -- no labelled fields
-                univ_tvs                       -- universally quantified vars
-                []                             -- no existential tvs for now
-                []                             -- no eq spec for now
-                []                             -- no context
-                arg_tys                        -- argument types
-                (mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)) -- return type
-                tycon'                         -- representation tycon
+  = do { name'   <- mkLocalisedName mkVectDataConOcc name
+       ; tycon'  <- vectTyCon tycon
+       ; arg_tys <- mapM vectType rep_arg_tys
+       ; let ret_ty = mkFamilyTyConApp tycon' (mkTyVarTys univ_tvs)
+       ; liftDs $ buildDataCon
+                    name'
+                    (dataConIsInfix dc)            -- infix if the original is
+                    (dataConStrictMarks dc)        -- strictness as original constructor
+                    []                             -- no labelled fields for now
+                    univ_tvs                       -- universally quantified vars
+                    []                             -- no existential tvs for now
+                    []                             -- no equalities for now
+                    []                             -- no context for now
+                    arg_tys                        -- argument types
+                    ret_ty                         -- return type
+                    tycon'                         -- representation tycon
+       }
   where
     name        = dataConName dc
-    univ_tvs    = dataConUnivTyVars dc
     rep_arg_tys = dataConRepArgTys dc
     tycon       = dataConTyCon dc
+    (univ_tvs, ex_tvs, eq_spec, theta, _arg_tys, _res_ty) = dataConFullSig dc
diff --git a/compiler/vectorise/Vectorise/Type/Type.hs b/compiler/vectorise/Vectorise/Type/Type.hs
index 64a4a22dab..cdd7bedf26 100644
--- a/compiler/vectorise/Vectorise/Type/Type.hs
+++ b/compiler/vectorise/Vectorise/Type/Type.hs
@@ -78,7 +78,6 @@ vectType ty@(ForAllTy _ _)
       dictsPA     <- liftM catMaybes $ mapM paDictArgType tyvars
 
       -- pack it all back together.
-      traceVt "vect ForAllTy: " $ ppr (abstractType tyvars (dictsPA ++ dictsVect) tyBody'')
       return $ abstractType tyvars (dictsPA ++ dictsVect) tyBody''
 
 -- |Add quantified vars and dictionary parameters to the front of a type.