Improve vectorisation warnings and errors

compiler/deSugar/DsMonad.lhs

@@ -193,7 +193,7 @@ initDs hsc_env mod rdr_env type_env thing_inside
               (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env msg_var
 
         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
-                          loadDAP dflags $
+                          loadDAP $
                             initDPHBuiltins $
                               tryM thing_inside     -- Catch exceptions (= errors during desugaring)
 
@@ -215,7 +215,7 @@ initDs hsc_env mod rdr_env type_env thing_inside
     -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
     --   * 'Data.Array.Parallel'      iff '-XParallalArrays' specified (see also 'checkLoadDAP').
     --   * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
-    loadDAP dflags thing_inside
+    loadDAP thing_inside
       = do { dapEnv  <- loadOneModule dATA_ARRAY_PARALLEL_NAME      checkLoadDAP          paErr
            ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (doptM Opt_Vectorise) veErr
            ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
@@ -233,13 +233,14 @@ initDs hsc_env mod rdr_env type_env thing_inside
                ; result <- liftIO $ findImportedModule hsc_env modname Nothing
                ; case result of
                    Found _ mod -> loadModule err mod
-                   _           -> do { liftIO $ fatalErrorMsg dflags err
-                                     ; panic "DsMonad.initDs: failed to load module"
-                                     }
+                   _           -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
                } }
 
-        paErr = ptext $ sLit "To use -XParallelArrays, you must specify a DPH backend package"
-        veErr = ptext $ sLit "To use -fvectorise, you must specify a DPH backend package"
+        paErr       = ptext (sLit "To use -XParallelArrays,") <+> specBackend $$ hint1 $$ hint2
+        veErr       = ptext (sLit "To use -fvectorise,") <+> specBackend $$ hint1 $$ hint2
+        specBackend = ptext (sLit "you must specify a DPH backend package")
+        hint1       = ptext (sLit "Look for packages named 'dph-lifted-*' with 'ghc-pkg'")
+        hint2       = ptext (sLit "You may need to install them with 'cabal install dph-examples'")
 
     initDPHBuiltins thing_inside
       = do {   -- If '-XParallelArrays' given, we populate the builtin table for desugaring those
@@ -291,13 +292,10 @@ mkDsEnvs dflags mod rdr_env type_env msg_var
 loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
 loadModule doc mod
   = do { env    <- getGblEnv
-       ; dflags <- getDOpts
        ; setEnvs (ds_if_env env) $ do
        { iface <- loadInterface doc mod ImportBySystem
        ; case iface of
-           Failed err      -> do { liftIO $ fatalErrorMsg dflags (err $$ doc)
-                                 ; panic "DsMonad.loadModule: failed to load"
-                                 }
+           Failed err      -> pprPanic "DsMonad.loadModule: failed to load" (err $$ doc)
            Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
        } }
   where

compiler/vectorise/Vectorise/Monad.hs

@@ -89,7 +89,6 @@ initV hsc_env guts info thing_inside
                  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
            ; let genv = extendImportedVarsEnv builtin_vars
                         . extendTyConsEnv     builtin_tycons
                         . setPAFunsEnv        builtin_pas
@@ -97,7 +96,7 @@ initV hsc_env guts info thing_inside
                         $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
  
                -- perform vectorisation
-           ; r <- runVM thing_inside' builtins genv emptyLocalEnv
+           ; r <- runVM thing_inside builtins genv emptyLocalEnv
            ; case r of
                Yes genv _ x -> return $ Just (new_info genv, x)
                No reason    -> do { unqual <- mkPrintUnqualifiedDs

compiler/vectorise/Vectorise/Type/Classify.hs

@@ -28,7 +28,9 @@ import Digraph
 
 -- |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.
+-- vectorised.  The third result list are those type constructors that we cannot convert (either
+-- because they use language extensions or because they dependent on type constructors for which
+-- no vectorised version is available).
 
 -- The first argument determines the /conversion status/ of external type constructors as follows:
 --
@@ -36,19 +38,19 @@ import Digraph
 -- * tycons which are not changed by vectorisation are mapped to 'False'
 -- * tycons which can't be converted are not elements of the map
 --
-classifyTyCons :: UniqFM Bool             -- ^type constructor conversion status
-               -> [TyCon]                 -- ^type constructors that need to be classified
-               -> ([TyCon], [TyCon])      -- ^tycons to be converted & not to be converted
-classifyTyCons convStatus tcs = classify [] [] convStatus (tyConGroups tcs)
+classifyTyCons :: UniqFM Bool                     -- ^type constructor conversion status
+               -> [TyCon]                         -- ^type constructors that need to be classified
+               -> ([TyCon], [TyCon], [TyCon])     -- ^tycons to be converted & not to be converted
+classifyTyCons convStatus tcs = classify [] [] [] convStatus (tyConGroups tcs)
   where
-    classify conv keep _  [] = (conv, keep)
-    classify conv keep cs ((tcs, ds) : rs)
+    classify conv keep ignored _  [] = (conv, keep, ignored)
+    classify conv keep ignored cs ((tcs, ds) : rs)
       | can_convert && must_convert
-      = classify (tcs ++ conv) keep (cs `addListToUFM` [(tc, True) | tc <- tcs]) rs
+      = classify (tcs ++ conv) keep ignored (cs `addListToUFM` [(tc, True) | tc <- tcs]) rs
       | can_convert
-      = classify conv (tcs ++ keep) (cs `addListToUFM` [(tc, False) | tc <- tcs]) rs
+      = classify conv (tcs ++ keep) ignored (cs `addListToUFM` [(tc, False) | tc <- tcs]) rs
       | otherwise
-      = classify conv keep cs rs
+      = classify conv keep (tcs ++ ignored) cs rs
       where
         refs = ds `delListFromUniqSet` tcs
 

compiler/vectorise/Vectorise/Type/Env.hs

@@ -162,9 +162,10 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
            -- appear in vectorised code.  (We also drop the local type constructors appearing in a
            -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as
            -- these are being handled separately.)
-       ; let maybeVectoriseTyCons   = filter notLocalScalarTyCon tycons ++ impVectTyCons
-             (conv_tcs, keep_tcs)   = classifyTyCons vectTyConFlavour maybeVectoriseTyCons
-             orig_tcs               = keep_tcs ++ conv_tcs
+           -- Furthermore, 'drop_tcs' are those type constructors that we cannot vectorise.
+       ; let maybeVectoriseTyCons           = filter notLocalScalarTyCon tycons ++ impVectTyCons
+             (conv_tcs, keep_tcs, drop_tcs) = classifyTyCons vectTyConFlavour maybeVectoriseTyCons
+             orig_tcs                       = keep_tcs ++ conv_tcs
              
        ; traceVt " VECT SCALAR    : " $ ppr localScalarTyCons
        ; traceVt " VECT [class]   : " $ ppr impVectTyCons
@@ -172,6 +173,13 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
        ; traceVt " -- after classification (local and VECT [class] tycons) --" empty
        ; traceVt " reuse          : " $ ppr keep_tcs
        ; traceVt " convert        : " $ ppr conv_tcs
+       
+           -- warn the user about unvectorised type constructors
+       ; let explanation = ptext (sLit "(They use unsupported language extensions") $$
+                           ptext (sLit "or depend on type constructors that are not vectorised)")
+       ; unless (null drop_tcs) $
+           emitVt "Warning: cannot vectorise these type constructors:" $ 
+             pprQuotedList drop_tcs $$ explanation
 
        ; let defTyConDataCons origTyCon vectTyCon
                = do { defTyCon origTyCon vectTyCon