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
Glasgow Haskell Compiler
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