Commit ec23c891 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Improve vectorisation warnings and errors

parent c2214c9d
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment