Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
ec23c891
Commit
ec23c891
authored
Nov 14, 2011
by
chak@cse.unsw.edu.au.
Browse files
Improve vectorisation warnings and errors
parent
c2214c9d
Changes
4
Hide whitespace changes
Inline
Side-by-side
compiler/deSugar/DsMonad.lhs
View file @
ec23c891
...
...
@@ -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
View file @
ec23c891
...
...
@@ -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
View file @
ec23c891
...
...
@@ -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
View file @
ec23c891
...
...
@@ -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
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment