diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/deSugar/DsMonad.lhs | 20 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Monad.hs | 3 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Type/Classify.hs | 22 | ||||
| -rw-r--r-- | compiler/vectorise/Vectorise/Type/Env.hs | 14 |
4 files changed, 33 insertions, 26 deletions
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 5efb5d1df4..8ea94efef3 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/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 diff --git a/compiler/vectorise/Vectorise/Monad.hs b/compiler/vectorise/Vectorise/Monad.hs index bd531867de..6fbdb4e3ad 100644 --- a/compiler/vectorise/Vectorise/Monad.hs +++ b/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 diff --git a/compiler/vectorise/Vectorise/Type/Classify.hs b/compiler/vectorise/Vectorise/Type/Classify.hs index 1a0a434adc..7122cb7664 100644 --- a/compiler/vectorise/Vectorise/Type/Classify.hs +++ b/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 diff --git a/compiler/vectorise/Vectorise/Type/Env.hs b/compiler/vectorise/Vectorise/Type/Env.hs index a6112c714c..042d127258 100644 --- a/compiler/vectorise/Vectorise/Type/Env.hs +++ b/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 |