Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Alex D
GHC
Commits
287d8483
Commit
287d8483
authored
Oct 23, 2010
by
Ian Lynagh
Browse files
Remove the need to explicitly flatten the dynflags
parent
28cb2d6d
Changes
4
Hide whitespace changes
Inline
Side-by-side
compiler/main/DriverPipeline.hs
View file @
287d8483
...
...
@@ -694,30 +694,27 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
runPhase
(
Cpp
sf
)
_stop
hsc_env
_basename
_suff
input_fn
get_output_fn
maybe_loc
=
do
let
dflags0
=
hsc_dflags
hsc_env
let
dflags0'
=
flattenExtensionFlags
dflags0
src_opts
<-
liftIO
$
getOptionsFromFile
dflags0'
input_fn
src_opts
<-
liftIO
$
getOptionsFromFile
dflags0
input_fn
(
dflags1
,
unhandled_flags
,
warns
)
<-
liftIO
$
parseDynamicNoPackageFlags
dflags0
src_opts
checkProcessArgsResult
unhandled_flags
let
dflags1'
=
flattenExtensionFlags
dflags1
if
not
(
xopt
Opt_Cpp
dflags1
'
)
then
do
if
not
(
xopt
Opt_Cpp
dflags1
)
then
do
-- we have to be careful to emit warnings only once.
unless
(
dopt
Opt_Pp
dflags1
'
)
$
handleFlagWarnings
dflags1
'
warns
unless
(
dopt
Opt_Pp
dflags1
)
$
handleFlagWarnings
dflags1
warns
-- no need to preprocess CPP, just pass input file along
-- to the next phase of the pipeline.
return
(
HsPp
sf
,
dflags1
,
maybe_loc
,
input_fn
)
else
do
output_fn
<-
liftIO
$
get_output_fn
dflags1
'
(
HsPp
sf
)
maybe_loc
liftIO
$
doCpp
dflags1
'
True
{-raw-}
False
{-no CC opts-}
input_fn
output_fn
output_fn
<-
liftIO
$
get_output_fn
dflags1
(
HsPp
sf
)
maybe_loc
liftIO
$
doCpp
dflags1
True
{-raw-}
False
{-no CC opts-}
input_fn
output_fn
-- re-read the pragmas now that we've preprocessed the file
-- See #2464,#3457
src_opts
<-
liftIO
$
getOptionsFromFile
dflags0
'
output_fn
src_opts
<-
liftIO
$
getOptionsFromFile
dflags0
output_fn
(
dflags2
,
unhandled_flags
,
warns
)
<-
liftIO
$
parseDynamicNoPackageFlags
dflags0
src_opts
let
dflags2'
=
flattenExtensionFlags
dflags2
unless
(
dopt
Opt_Pp
dflags2'
)
$
handleFlagWarnings
dflags2'
warns
unless
(
dopt
Opt_Pp
dflags2
)
$
handleFlagWarnings
dflags2
warns
-- the HsPp pass below will emit warnings
checkProcessArgsResult
unhandled_flags
...
...
@@ -728,11 +725,10 @@ runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
runPhase
(
HsPp
sf
)
_stop
hsc_env
basename
suff
input_fn
get_output_fn
maybe_loc
=
do
let
dflags
=
hsc_dflags
hsc_env
dflags'
=
flattenExtensionFlags
dflags
if
not
(
dopt
Opt_Pp
dflags
)
then
-- no need to preprocess, just pass input file along
-- to the next phase of the pipeline.
return
(
Hsc
sf
,
dflags
'
,
maybe_loc
,
input_fn
)
return
(
Hsc
sf
,
dflags
,
maybe_loc
,
input_fn
)
else
do
let
hspp_opts
=
getOpts
dflags
opt_F
let
orig_fn
=
basename
<.>
suff
...
...
@@ -746,14 +742,13 @@ runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
)
-- re-read pragmas now that we've parsed the file (see #3674)
src_opts
<-
liftIO
$
getOptionsFromFile
dflags
'
output_fn
src_opts
<-
liftIO
$
getOptionsFromFile
dflags
output_fn
(
dflags1
,
unhandled_flags
,
warns
)
<-
liftIO
$
parseDynamicNoPackageFlags
dflags
src_opts
let
dflags1'
=
flattenExtensionFlags
dflags1
handleFlagWarnings
dflags1'
warns
handleFlagWarnings
dflags1
warns
checkProcessArgsResult
unhandled_flags
return
(
Hsc
sf
,
dflags1
'
,
maybe_loc
,
output_fn
)
return
(
Hsc
sf
,
dflags1
,
maybe_loc
,
output_fn
)
-----------------------------------------------------------------------------
-- Hsc phase
...
...
@@ -901,14 +896,13 @@ runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _ma
runPhase
CmmCpp
_stop
hsc_env
_basename
_suff
input_fn
get_output_fn
maybe_loc
=
do
let
dflags
=
hsc_dflags
hsc_env
dflags'
=
flattenExtensionFlags
dflags
output_fn
<-
liftIO
$
get_output_fn
dflags'
Cmm
maybe_loc
liftIO
$
doCpp
dflags'
False
{-not raw-}
True
{-include CC opts-}
input_fn
output_fn
return
(
Cmm
,
dflags'
,
maybe_loc
,
output_fn
)
output_fn
<-
liftIO
$
get_output_fn
dflags
Cmm
maybe_loc
liftIO
$
doCpp
dflags
False
{-not raw-}
True
{-include CC opts-}
input_fn
output_fn
return
(
Cmm
,
dflags
,
maybe_loc
,
output_fn
)
runPhase
Cmm
stop
hsc_env
basename
_
input_fn
get_output_fn
maybe_loc
=
do
let
dflags
=
ensureFlattenedExtensionFlags
$
hsc_dflags
hsc_env
let
dflags
=
hsc_dflags
hsc_env
let
hsc_lang
=
hscMaybeAdjustTarget
dflags
stop
HsSrcFile
(
hscTarget
dflags
)
let
next_phase
=
hscNextPhase
dflags
HsSrcFile
hsc_lang
output_fn
<-
liftIO
$
get_output_fn
dflags
next_phase
maybe_loc
...
...
compiler/main/DynFlags.hs
View file @
287d8483
...
...
@@ -17,16 +17,12 @@ module DynFlags (
DynFlag
(
..
),
ExtensionFlag
(
..
),
glasgowExtsFlags
,
flattenExtensionFlags
,
ensureFlattenedExtensionFlags
,
dopt
,
dopt_set
,
dopt_unset
,
xopt
,
xopt_set
,
xopt_unset
,
xopt_set_flattened
,
xopt_unset_flattened
,
DynFlags
(
..
),
RtsOptsEnabled
(
..
),
HscTarget
(
..
),
isObjectTarget
,
defaultObjectTarget
,
...
...
@@ -501,9 +497,13 @@ data DynFlags = DynFlags {
-- hsc dynamic flags
flags
::
[
DynFlag
],
-- Don't change this without updating extensionFlags:
language
::
Maybe
Language
,
extensionFlags
::
Either
[
OnOff
ExtensionFlag
]
[
ExtensionFlag
],
-- Don't change this without updating extensionFlags:
extensions
::
[
OnOff
ExtensionFlag
],
-- extensionFlags should always be equal to
-- flattenExtensionFlags language extensions
extensionFlags
::
[
ExtensionFlag
],
-- | Message output action: use "ErrUtils" instead of this if you can
log_action
::
Severity
->
SrcSpan
->
PprStyle
->
Message
->
IO
()
,
...
...
@@ -741,7 +741,8 @@ defaultDynFlags =
haddockOptions
=
Nothing
,
flags
=
defaultFlags
,
language
=
Nothing
,
extensionFlags
=
Left
[]
,
extensions
=
[]
,
extensionFlags
=
flattenExtensionFlags
Nothing
[]
,
log_action
=
\
severity
srcSpan
style
msg
->
case
severity
of
...
...
@@ -770,31 +771,11 @@ Note [Verbosity levels]
data
OnOff
a
=
On
a
|
Off
a
flattenExtensionFlags
::
DynFlags
->
DynFlags
flattenExtensionFlags
dflags
=
case
extensionFlags
dflags
of
Left
onoffs
->
dflags
{
extensionFlags
=
Right
$
flattenExtensionFlags'
(
language
dflags
)
onoffs
}
Right
_
->
panic
"Flattening already-flattened extension flags"
ensureFlattenedExtensionFlags
::
DynFlags
->
DynFlags
ensureFlattenedExtensionFlags
dflags
=
case
extensionFlags
dflags
of
Left
onoffs
->
dflags
{
extensionFlags
=
Right
$
flattenExtensionFlags'
(
language
dflags
)
onoffs
}
Right
_
->
dflags
-- OnOffs accumulate in reverse order, so we use foldr in order to
-- process them in the right order
flattenExtensionFlags
'
::
Maybe
Language
->
[
OnOff
ExtensionFlag
]
->
[
ExtensionFlag
]
flattenExtensionFlags
'
ml
=
foldr
f
defaultExtensionFlags
flattenExtensionFlags
::
Maybe
Language
->
[
OnOff
ExtensionFlag
]
->
[
ExtensionFlag
]
flattenExtensionFlags
ml
=
foldr
f
defaultExtensionFlags
where
f
(
On
f
)
flags
=
f
:
delete
f
flags
f
(
Off
f
)
flags
=
delete
f
flags
defaultExtensionFlags
=
languageExtensions
ml
...
...
@@ -837,37 +818,30 @@ dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) }
-- | Test whether a 'ExtensionFlag' is set
xopt
::
ExtensionFlag
->
DynFlags
->
Bool
xopt
f
dflags
=
case
extensionFlags
dflags
of
Left
_
->
panic
(
"Testing for extension flag "
++
show
f
++
" before flattening"
)
Right
flags
->
f
`
elem
`
flags
xopt
f
dflags
=
f
`
elem
`
extensionFlags
dflags
-- | Set a 'ExtensionFlag'
xopt_set
::
DynFlags
->
ExtensionFlag
->
DynFlags
xopt_set
dfs
f
=
case
extensionFlags
dfs
of
Left
onoffs
->
dfs
{
extensionFlags
=
Left
(
On
f
:
onoffs
)
}
Right
_
->
panic
(
"Setting extension flag "
++
show
f
++
" after flattening"
)
-- | Set a 'ExtensionFlag'
xopt_set_flattened
::
DynFlags
->
ExtensionFlag
->
DynFlags
xopt_set_flattened
dfs
f
=
case
extensionFlags
dfs
of
Left
_
->
panic
(
"Setting extension flag "
++
show
f
++
" before flattening, but expected flattened"
)
Right
flags
->
dfs
{
extensionFlags
=
Right
(
f
:
delete
f
flags
)
}
xopt_set
dfs
f
=
let
onoffs
=
On
f
:
extensions
dfs
in
dfs
{
extensions
=
onoffs
,
extensionFlags
=
flattenExtensionFlags
(
language
dfs
)
onoffs
}
-- | Unset a 'ExtensionFlag'
xopt_unset
::
DynFlags
->
ExtensionFlag
->
DynFlags
xopt_unset
dfs
f
=
case
extensionFlags
dfs
of
Left
onoffs
->
dfs
{
extensionFlags
=
Left
(
Off
f
:
onoffs
)
}
Right
_
->
panic
(
"Unsetting extension flag "
++
show
f
++
" after flattening"
)
xopt_unset
dfs
f
=
let
onoffs
=
Off
f
:
extensions
dfs
in
dfs
{
extensions
=
onoffs
,
extensionFlags
=
flattenExtensionFlags
(
language
dfs
)
onoffs
}
-- | Unset a 'ExtensionFlag'
xopt_unset_flattened
::
DynFlags
->
ExtensionFlag
->
DynFlags
xopt_unset_flattened
dfs
f
=
case
extensionFlags
dfs
of
Left
_
->
panic
(
"Unsetting extension flag "
++
show
f
++
" before flattening, but expected flattened"
)
Right
flags
->
dfs
{
extensionFlags
=
Right
(
delete
f
flags
)
}
setLanguage
::
Language
->
DynP
()
setLanguage
l
=
upd
f
where
f
dfs
=
let
mLang
=
Just
l
oneoffs
=
extensions
dfs
in
dfs
{
language
=
mLang
,
extensionFlags
=
flattenExtensionFlags
mLang
oneoffs
}
-- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order
getOpts
::
DynFlags
-- ^ 'DynFlags' to retrieve the options from
...
...
@@ -1871,10 +1845,6 @@ setDynFlag, unSetDynFlag :: DynFlag -> DynP ()
setDynFlag
f
=
upd
(
\
dfs
->
dopt_set
dfs
f
)
unSetDynFlag
f
=
upd
(
\
dfs
->
dopt_unset
dfs
f
)
--------------------------
setLanguage
::
Language
->
DynP
()
setLanguage
l
=
upd
(
\
dfs
->
dfs
{
language
=
Just
l
})
--------------------------
setExtensionFlag
,
unSetExtensionFlag
::
ExtensionFlag
->
DynP
()
setExtensionFlag
f
=
do
{
upd
(
\
dfs
->
xopt_set
dfs
f
)
...
...
compiler/typecheck/TcRnMonad.lhs
View file @
287d8483
...
...
@@ -253,7 +253,7 @@ doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) }
setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
setOptM flag = updEnv (\ env@(Env { env_top = top }) ->
env { env_top = top { hsc_dflags = xopt_set
_flattened
(hsc_dflags top) flag}} )
env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} )
unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a
unsetOptM flag = updEnv (\ env@(Env { env_top = top }) ->
...
...
ghc/InteractiveUI.hs
View file @
287d8483
...
...
@@ -1194,7 +1194,7 @@ shellEscape str = io (system str >> return False)
withFlattenedDynflags
::
GHC
.
GhcMonad
m
=>
m
a
->
m
a
withFlattenedDynflags
m
=
do
dflags
<-
GHC
.
getSessionDynFlags
gbracket
(
GHC
.
setSessionDynFlags
(
ensureFlattenedExtensionFlags
dflags
)
)
gbracket
(
GHC
.
setSessionDynFlags
dflags
)
(
\
_
->
GHC
.
setSessionDynFlags
dflags
)
(
\
_
->
m
)
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Attach a 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