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 ...@@ -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 (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 $ ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
loadDAP dflags $ loadDAP $
initDPHBuiltins $ initDPHBuiltins $
tryM thing_inside -- Catch exceptions (= errors during desugaring) tryM thing_inside -- Catch exceptions (= errors during desugaring)
...@@ -215,7 +215,7 @@ initDs hsc_env mod rdr_env type_env thing_inside ...@@ -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 -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
-- * 'Data.Array.Parallel' iff '-XParallalArrays' specified (see also 'checkLoadDAP'). -- * 'Data.Array.Parallel' iff '-XParallalArrays' specified (see also 'checkLoadDAP').
-- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified. -- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
loadDAP dflags thing_inside loadDAP thing_inside
= do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr
; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (doptM Opt_Vectorise) veErr ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (doptM Opt_Vectorise) veErr
; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside ; 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 ...@@ -233,13 +233,14 @@ initDs hsc_env mod rdr_env type_env thing_inside
; result <- liftIO $ findImportedModule hsc_env modname Nothing ; result <- liftIO $ findImportedModule hsc_env modname Nothing
; case result of ; case result of
Found _ mod -> loadModule err mod Found _ mod -> loadModule err mod
_ -> do { liftIO $ fatalErrorMsg dflags err _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
; panic "DsMonad.initDs: failed to load module"
}
} } } }
paErr = ptext $ sLit "To use -XParallelArrays, you must specify a DPH backend package" paErr = ptext (sLit "To use -XParallelArrays,") <+> specBackend $$ hint1 $$ hint2
veErr = ptext $ sLit "To use -fvectorise, you must specify a DPH backend package" 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 initDPHBuiltins thing_inside
= do { -- If '-XParallelArrays' given, we populate the builtin table for desugaring those = 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 ...@@ -291,13 +292,10 @@ mkDsEnvs dflags mod rdr_env type_env msg_var
loadModule :: SDoc -> Module -> DsM GlobalRdrEnv loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
loadModule doc mod loadModule doc mod
= do { env <- getGblEnv = do { env <- getGblEnv
; dflags <- getDOpts
; setEnvs (ds_if_env env) $ do ; setEnvs (ds_if_env env) $ do
{ iface <- loadInterface doc mod ImportBySystem { iface <- loadInterface doc mod ImportBySystem
; case iface of ; case iface of
Failed err -> do { liftIO $ fatalErrorMsg dflags (err $$ doc) Failed err -> pprPanic "DsMonad.loadModule: failed to load" (err $$ doc)
; panic "DsMonad.loadModule: failed to load"
}
Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
} } } }
where where
......
...@@ -89,7 +89,6 @@ initV hsc_env guts info thing_inside ...@@ -89,7 +89,6 @@ initV hsc_env guts info thing_inside
builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances builtin_prs = initClassDicts instEnvs (prClass builtins) -- ..'PR' class instances
-- construct the initial global environment -- construct the initial global environment
; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside
; let genv = extendImportedVarsEnv builtin_vars ; let genv = extendImportedVarsEnv builtin_vars
. extendTyConsEnv builtin_tycons . extendTyConsEnv builtin_tycons
. setPAFunsEnv builtin_pas . setPAFunsEnv builtin_pas
...@@ -97,7 +96,7 @@ initV hsc_env guts info thing_inside ...@@ -97,7 +96,7 @@ initV hsc_env guts info thing_inside
$ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs
-- perform vectorisation -- perform vectorisation
; r <- runVM thing_inside' builtins genv emptyLocalEnv ; r <- runVM thing_inside builtins genv emptyLocalEnv
; case r of ; case r of
Yes genv _ x -> return $ Just (new_info genv, x) Yes genv _ x -> return $ Just (new_info genv, x)
No reason -> do { unqual <- mkPrintUnqualifiedDs No reason -> do { unqual <- mkPrintUnqualifiedDs
......
...@@ -28,7 +28,9 @@ import Digraph ...@@ -28,7 +28,9 @@ import Digraph
-- |From a list of type constructors, extract those that can 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/ -- 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: -- The first argument determines the /conversion status/ of external type constructors as follows:
-- --
...@@ -36,19 +38,19 @@ import Digraph ...@@ -36,19 +38,19 @@ import Digraph
-- * tycons which are not changed by vectorisation are mapped to 'False' -- * tycons which are not changed by vectorisation are mapped to 'False'
-- * tycons which can't be converted are not elements of the map -- * tycons which can't be converted are not elements of the map
-- --
classifyTyCons :: UniqFM Bool -- ^type constructor conversion status classifyTyCons :: UniqFM Bool -- ^type constructor conversion status
-> [TyCon] -- ^type constructors that need to be classified -> [TyCon] -- ^type constructors that need to be classified
-> ([TyCon], [TyCon]) -- ^tycons to be converted & not to be converted -> ([TyCon], [TyCon], [TyCon]) -- ^tycons to be converted & not to be converted
classifyTyCons convStatus tcs = classify [] [] convStatus (tyConGroups tcs) classifyTyCons convStatus tcs = classify [] [] [] convStatus (tyConGroups tcs)
where where
classify conv keep _ [] = (conv, keep) classify conv keep ignored _ [] = (conv, keep, ignored)
classify conv keep cs ((tcs, ds) : rs) classify conv keep ignored cs ((tcs, ds) : rs)
| can_convert && must_convert | 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 | 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 | otherwise
= classify conv keep cs rs = classify conv keep (tcs ++ ignored) cs rs
where where
refs = ds `delListFromUniqSet` tcs refs = ds `delListFromUniqSet` tcs
......
...@@ -162,9 +162,10 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls ...@@ -162,9 +162,10 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
-- appear in vectorised code. (We also drop the local type constructors appearing in a -- 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 -- VECTORISE SCALAR pragma or a VECTORISE pragma with an explicit right-hand side, as
-- these are being handled separately.) -- these are being handled separately.)
; let maybeVectoriseTyCons = filter notLocalScalarTyCon tycons ++ impVectTyCons -- Furthermore, 'drop_tcs' are those type constructors that we cannot vectorise.
(conv_tcs, keep_tcs) = classifyTyCons vectTyConFlavour maybeVectoriseTyCons ; let maybeVectoriseTyCons = filter notLocalScalarTyCon tycons ++ impVectTyCons
orig_tcs = keep_tcs ++ conv_tcs (conv_tcs, keep_tcs, drop_tcs) = classifyTyCons vectTyConFlavour maybeVectoriseTyCons
orig_tcs = keep_tcs ++ conv_tcs
; traceVt " VECT SCALAR : " $ ppr localScalarTyCons ; traceVt " VECT SCALAR : " $ ppr localScalarTyCons
; traceVt " VECT [class] : " $ ppr impVectTyCons ; traceVt " VECT [class] : " $ ppr impVectTyCons
...@@ -172,6 +173,13 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls ...@@ -172,6 +173,13 @@ vectTypeEnv tycons vectTypeDecls vectClassDecls
; traceVt " -- after classification (local and VECT [class] tycons) --" empty ; traceVt " -- after classification (local and VECT [class] tycons) --" empty
; traceVt " reuse : " $ ppr keep_tcs ; traceVt " reuse : " $ ppr keep_tcs
; traceVt " convert : " $ ppr conv_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 ; let defTyConDataCons origTyCon vectTyCon
= do { defTyCon 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