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

9 files changed, 84 insertions, 24 deletions

diff --git a/.gitignore b/.gitignore
index 4897988477..e65a4c26ec 100644
--- a/.gitignore
+++ b/.gitignore
@@ -240,3 +240,5 @@ _darcs/
 
 
 /extra-gcc-opts
+
+.tm_properties
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 86a512469a..6e29165975 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -622,7 +622,7 @@ addFingerprints hsc_env mb_old_fingerprint iface0 new_decls
                 mi_orphan      = not (   null orph_rules
                                       && null orph_insts
                                       && null orph_fis
-                                      && null (ifaceVectInfoVar (mi_vect_info iface0))),
+                                      && isNoIfaceVectInfo (mi_vect_info iface0))),
                 mi_finsts      = not . null $ mi_fam_insts iface0,
                 mi_decls       = sorted_decls,
                 mi_hash_fn     = lookupOccEnv local_env }
diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 5894607f28..6946752158 100644
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -745,9 +745,9 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
        ; tyConRes1   <- mapM (vectTyConVectMapping varsSet)  tycons
        ; tyConRes2   <- mapM (vectTyConReuseMapping varsSet) tyconsReuse
        ; vScalarVars <- mapM vectVar                         scalarVars
-       ; let (vTyCons, vDataCons) = unzip (tyConRes1 ++ tyConRes2)
+       ; let (vTyCons, vDataCons, vScSels) = unzip3 (tyConRes1 ++ tyConRes2)
        ; return $ VectInfo 
-                  { vectInfoVar          = mkVarEnv  vVars
+                  { vectInfoVar          = mkVarEnv  vVars `extendVarEnvList` concat vScSels
                   , vectInfoTyCon        = mkNameEnv vTyCons
                   , vectInfoDataCon      = mkNameEnv (concat vDataCons)
                   , vectInfoScalarVars   = mkVarSet  vScalarVars
@@ -765,6 +765,19 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
                        tcIfaceExtId vName
            ; return (var, (var, vVar))
            }
+      -- where
+      --   lookupLocalOrExternalId name
+      --     = do { let mb_id = lookupTypeEnv typeEnv name
+      --          ; case mb_id of
+      --                -- id is local
+      --              Just (AnId id) -> return id
+      --                -- name is not an Id => internal inconsistency
+      --              Just _         -> notAnIdErr
+      --                -- Id is external
+      --              Nothing        -> tcIfaceExtId name
+      --          }
+      -- 
+      --   notAnIdErr = pprPanic "TcIface.tcIfaceVectInfo: not an id" (ppr name)
 
     vectVar name 
       = forkM (ptext (sLit "vect scalar var")  <+> ppr name)  $
@@ -779,13 +792,17 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
       = vectTyConMapping vars name name
 
     vectTyConMapping vars name vName
-      = do { tycon  <- lookupLocalOrExternal name
-           ; vTycon <- lookupLocalOrExternal vName
+      = do { tycon  <- lookupLocalOrExternalTyCon name
+           ; vTycon <- forkM (ptext (sLit "vTycon of") <+> ppr vName) $ 
+                         lookupLocalOrExternalTyCon vName
 
-               -- map the data constructors of the original type constructor to those of the
+               -- Map the data constructors of the original type constructor to those of the
                -- vectorised type constructor /unless/ the type constructor was vectorised
                -- abstractly; if it was vectorised abstractly, the workers of its data constructors
-               -- do not appear in the set of vectorised variables
+               -- do not appear in the set of vectorised variables.
+               --
+               -- NB: This is lazy!  We don't pull at the type constructors before we actually use
+               --     the data constructor mapping.
            ; let isAbstract | isClassTyCon tycon = False
                             | datacon:_ <- tyConDataCons tycon 
                                                  = not $ dataConWrapId datacon `elemVarSet` vars
@@ -796,14 +813,25 @@ tcIfaceVectInfo mod typeEnv (IfaceVectInfo
                                                                         (tyConDataCons vTycon)
                                            ]
 
+                   -- Map the (implicit) superclass and methods selectors as they don't occur in
+                   -- the var map.
+                 vScSels    | Just cls  <- tyConClass_maybe tycon
+                            , Just vCls <- tyConClass_maybe vTycon 
+                            = [ (sel, (sel, vSel))
+                              | (sel, vSel) <- zip (classAllSelIds cls) (classAllSelIds vCls)
+                              ]
+                            | otherwise
+                            = []
+
            ; return ( (name, (tycon, vTycon))          -- (T, T_v)
                     , vDataCons                        -- list of (Ci, Ci_v)
+                    , vScSels                          -- list of (seli, seli_v)
                     )
            }
       where
           -- we need a fully defined version of the type constructor to be able to extract
           -- its data constructors etc.
-        lookupLocalOrExternal name
+        lookupLocalOrExternalTyCon name
           = do { let mb_tycon = lookupTypeEnv typeEnv name
                ; case mb_tycon of
                      -- tycon is local
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index db81bc43f0..3224acf0fe 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -92,7 +92,7 @@ module HscTypes (
 
         -- * Vectorisation information
         VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
-        noIfaceVectInfo,
+        noIfaceVectInfo, isNoIfaceVectInfo,
 
         -- * Safe Haskell information
         hscGetSafeInf, hscSetSafeInf,
@@ -696,8 +696,8 @@ data ModIface
         mi_insts       :: [IfaceClsInst],     -- ^ Sorted class instance
         mi_fam_insts   :: [IfaceFamInst],  -- ^ Sorted family instances
         mi_rules       :: [IfaceRule],     -- ^ Sorted rules
-        mi_orphan_hash :: !Fingerprint,    -- ^ Hash for orphan rules and class
-                                           -- and family instances combined
+        mi_orphan_hash :: !Fingerprint,    -- ^ Hash for orphan rules, class and family
+                                           -- instances, and vectorise pragmas combined
 
         mi_vect_info :: !IfaceVectInfo,    -- ^ Vectorisation information
 
@@ -1566,6 +1566,8 @@ lookupFixity env n = case lookupNameEnv env n of
 --
 -- * A transformation rule in a module other than the one defining
 --   the function in the head of the rule
+--
+-- * A vectorisation pragma
 type WhetherHasOrphans   = Bool
 
 -- | Does this module define family instances?
@@ -2009,6 +2011,10 @@ concatVectInfo = foldr plusVectInfo noVectInfo
 noIfaceVectInfo :: IfaceVectInfo
 noIfaceVectInfo = IfaceVectInfo [] [] [] [] []
 
+isNoIfaceVectInfo :: IfaceVectInfo -> Bool
+isNoIfaceVectInfo (IfaceVectInfo l1 l2 l3 l4 l5)
+  = null l1 && null l2 && null l3 && null l4 && null l5
+
 instance Outputable VectInfo where
   ppr info = vcat
              [ ptext (sLit "variables     :") <+> ppr (vectInfoVar          info)
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 5e2a9375a0..3107b794b3 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -513,6 +513,7 @@ tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar          = vars
                                tidy_var_v = lookup_var var_v
                          , isExportedId tidy_var
                          , isExportedId tidy_var_v
+                         , not $ isImplicitId var
                          ]
 
     tidy_scalarVars = mkVarSet [ lookup_var var 
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 197f2b2554..c676a9bff1 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -682,7 +682,7 @@ rnHsVectDecl (HsVectClassOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectClassOut'"
 rnHsVectDecl (HsVectInstIn instTy)
   = do { instTy' <- rnLHsInstType (text "In a VECTORISE pragma") instTy
-       ; return (HsVectInstIn instTy', emptyFVs)
+       ; return (HsVectInstIn instTy', extractHsTyNames instTy')
        }
 rnHsVectDecl (HsVectInstOut _)
   = panic "RnSource.rnHsVectDecl: Unexpected 'HsVectInstOut'"
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