Fix vectorisation of classes

- Make sure that we have no implicit names in ifaces
- Any vectorisation info makes a module an orphan module
- Allow 'Show' in vectorised code without vectorising it for the moment

3 files changed, 35 insertions, 12 deletions

diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs
index a6bf6d973f..426682cea8 100644
--- a/compiler/vectorise/Vectorise/Monad.hs
+++ b/compiler/vectorise/Vectorise/Monad.hs
@@ -54,12 +54,12 @@ initV :: HscEnv
       -> VM a
       -> IO (Maybe (VectInfo, a))
 initV hsc_env guts info thing_inside
-  = do {
-         let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
+  = do { dumpIfVtTrace "Incoming VectInfo" (ppr info)
+
+       ; let type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
        ; (_, Just res) <- initDs hsc_env (mg_module guts)
                                          (mg_rdr_env guts) type_env go
 
-       ; dumpIfVtTrace "Incoming VectInfo" (ppr info)
        ; case res of
            Nothing
              -> dumpIfVtTrace "Vectorisation FAILED!" empty
diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs
index 7122cb7664..ead7f14ea7 100644
--- a/compiler/vectorise/Vectorise/Type/Classify.hs
+++ b/compiler/vectorise/Vectorise/Type/Classify.hs
@@ -23,6 +23,7 @@ import DataCon
 import TyCon
 import TypeRep
 import Type
+import PrelNames
 import Digraph
 
 
@@ -54,14 +55,21 @@ classifyTyCons convStatus tcs = classify [] [] [] convStatus (tyConGroups tcs)
       where
         refs = ds `delListFromUniqSet` tcs
 
-        can_convert  = isNullUFM (refs `minusUFM` cs) && all convertable tcs
+        can_convert  = (isNullUFM (refs `minusUFM` cs) && all convertable tcs)
+                       || isShowClass tcs
         must_convert = foldUFM (||) False (intersectUFM_C const cs refs)
+                       && (not . isShowClass $ tcs)
 
         -- 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
+            
+        -- !!!FIXME: currently we allow 'Show' in vectorised code without actually providing a
+        --   vectorised definition (to be able to vectorise 'Num')
+        isShowClass [tc] = tyConName tc == showClassName
+        isShowClass _    = False
 
 -- 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 a6f77bb9db..0051d072a4 100644
--- a/compiler/vectorise/Vectorise/Type/Env.hs
+++ b/compiler/vectorise/Vectorise/Type/Env.hs
@@ -147,14 +147,6 @@ vectTypeEnv :: [TyCon]                  -- Type constructors defined in this mod
 vectTypeEnv tycons vectTypeDecls vectClassDecls
   = do { traceVt "** vectTypeEnv" $ ppr tycons
 
-         -- Build a map containing all vectorised type constructor.  If they are scalar, they are
-         -- mapped to 'False' (vectorised type constructor == original type constructor).
-       ; allScalarTyConNames <- globalScalarTyCons  -- covers both current and imported modules
-       ; vectTyCons          <- globalVectTyCons
-       ; let vectTyConBase    = mapNameEnv (const True) vectTyCons   -- by default fully vectorised
-             vectTyConFlavour = foldNameSet (\n env -> extendNameEnv env n False) vectTyConBase
-                                            allScalarTyConNames
-
        ; let   -- {-# VECTORISE SCALAR type T -#} (imported and local tycons)
              localAbstractTyCons    = [tycon | VectType True tycon Nothing <- vectTypeDecls]
 
@@ -172,6 +164,23 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
                                         localAbstractTyCons ++ map fst3 vectTyConsWithRHS
              notVectSpecialTyCon tc = not $ (tyConName tc) `elemNameSet` vectSpecialTyConNames
 
+         -- Build a map containing all vectorised type constructor.  If they are scalar, they are
+         -- mapped to 'False' (vectorised type constructor == original type constructor).
+       ; allScalarTyConNames <- globalScalarTyCons  -- covers both current and imported modules
+       ; vectTyCons          <- globalVectTyCons
+       ; let vectTyConBase    = mapNameEnv (const True) vectTyCons    -- by default fully vectorised
+             vectTyConFlavour = vectTyConBase 
+                                `plusNameEnv` 
+                                mkNameEnv [ (tyConName tycon, True) 
+                                          | (tycon, _, _) <- vectTyConsWithRHS]
+                                `plusNameEnv`
+                                mkNameEnv [ (tcName, False)           -- original representation
+                                          | tcName <- nameSetToList allScalarTyConNames]
+                                `plusNameEnv`
+                                mkNameEnv [ (tyConName tycon, False)  -- original representation
+                                          | tycon <- localAbstractTyCons]
+                                            
+
            -- Split the list of 'TyCons' into the ones (1) that we must vectorise and those (2)
            -- that we could, but don't need to vectorise.  Type constructors that are not data
            -- type constructors or use non-Haskell98 features are being dropped.  They may not
@@ -219,6 +228,12 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
            -- 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
+       
+       ; let dumpTc tc vTc = traceVt "---" (ppr tc <+> text "::" <+> ppr (dataConSig tc) $$
+                                            ppr vTc <+> text "::" <+> ppr (dataConSig vTc))
+             dataConSig tc | Just dc <- tyConSingleDataCon_maybe tc = dataConRepType dc
+                           | otherwise                              = panic "dataConSig"
+       ; zipWithM_ dumpTc (filter isClassTyCon conv_tcs) (filter isClassTyCon new_tcs)
 
            -- We don't need new representation types for dictionary constructors. The constructors
            -- are always fully applied, and we don't need to lift them to arrays as a dictionary