Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Tobias Decking
GHC
Commits
96ea76c7
Commit
96ea76c7
authored
Jan 11, 2013
by
ian@well-typed.com
Browse files
dynamic-too progress
parent
35428a3a
Changes
2
Hide whitespace changes
Inline
Side-by-side
compiler/main/DriverPipeline.hs
View file @
96ea76c7
...
...
@@ -516,14 +516,23 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
basename
|
Just
b
<-
mb_basename
=
b
|
otherwise
=
input_basename
env
=
PipeEnv
{
stop_phase
,
-- If we were given a -x flag, then use that phase to start from
start_phase
=
fromMaybe
(
startPhase
suffix'
)
mb_phase
isHaskell
(
Unlit
_
)
=
True
isHaskell
(
Cpp
_
)
=
True
isHaskell
(
HsPp
_
)
=
True
isHaskell
(
Hsc
_
)
=
True
isHaskell
_
=
False
isHaskellishFile
=
isHaskell
start_phase
env
=
PipeEnv
{
pe_isHaskellishFile
=
isHaskellishFile
,
stop_phase
,
src_basename
=
basename
,
src_suffix
=
suffix'
,
output_spec
=
output
}
-- If we were given a -x flag, then use that phase to start from
start_phase
=
fromMaybe
(
startPhase
suffix'
)
mb_phase
-- We want to catch cases of "you can't get there from here" before
-- we start the pipeline, because otherwise it will just run off the
-- end.
...
...
@@ -536,14 +545,26 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
(
"cannot compile this file to desired target: "
++
input_fn
))
debugTraceMsg
dflags
4
(
text
"Running the pipeline"
)
r
<-
runPipeline'
start_phase
stop_phase
hsc_env
env
input_fn
output
maybe_loc
maybe_stub_o
-- If we are compiling a Haskell module, and doing
-- -dynamic-too, but couldn't do the -dynamic-too fast
-- path, then rerun the pipeline for the dyn way
let
dflags
=
extractDynFlags
hsc_env
whenCannotGenerateDynamicToo
dflags
$
do
when
isHaskellishFile
$
whenCannotGenerateDynamicToo
dflags
$
do
debugTraceMsg
dflags
4
(
text
"Running the pipeline again for -dynamic-too"
)
let
dflags'
=
doDynamicToo
dflags
-- TODO: This should use -dyno
output'
=
case
output
of
SpecificFile
fn
->
SpecificFile
(
replaceExtension
fn
(
objectSuf
dflags'
))
Persistent
->
Persistent
Temporary
->
Temporary
hsc_env'
<-
newHscEnv
dflags'
_
<-
runPipeline'
start_phase
stop_phase
hsc_env'
env
input_fn
output
maybe_loc
maybe_stub_o
output
'
maybe_loc
maybe_stub_o
return
()
return
r
...
...
@@ -593,6 +614,7 @@ runPipeline' start_phase stop_phase hsc_env env input_fn
-- PipeEnv: invariant information passed down
data
PipeEnv
=
PipeEnv
{
pe_isHaskellishFile
::
Bool
,
stop_phase
::
Phase
,
-- ^ Stop just before this phase
src_basename
::
String
,
-- ^ basename of original input source
src_suffix
::
String
,
-- ^ its extension
...
...
compiler/main/DynFlags.hs
View file @
96ea76c7
...
...
@@ -590,6 +590,7 @@ data DynFlags = DynFlags {
dynHiSuf
::
String
,
outputFile
::
Maybe
String
,
dynOutputFile
::
Maybe
String
,
outputHi
::
Maybe
String
,
dynLibLoader
::
DynLibLoader
,
...
...
@@ -1144,6 +1145,7 @@ doDynamicToo :: DynFlags -> DynFlags
doDynamicToo
dflags0
=
let
dflags1
=
unSetGeneralFlag'
Opt_Static
dflags0
dflags2
=
addWay'
WayDyn
dflags1
dflags3
=
dflags2
{
outputFile
=
dynOutputFile
dflags2
,
hiSuf
=
dynHiSuf
dflags2
,
objectSuf
=
dynObjectSuf
dflags2
}
...
...
@@ -1222,6 +1224,7 @@ defaultDynFlags mySettings =
pluginModNameOpts
=
[]
,
outputFile
=
Nothing
,
dynOutputFile
=
Nothing
,
outputHi
=
Nothing
,
dynLibLoader
=
SystemDependent
,
dumpPrefix
=
Nothing
,
...
...
@@ -1594,7 +1597,7 @@ setObjectDir, setHiDir, setStubDir, setDumpDir, setOutputDir,
addCmdlineFramework
,
addHaddockOpts
,
addGhciScript
,
setInteractivePrint
::
String
->
DynFlags
->
DynFlags
setOutputFile
,
setOutputHi
,
setDumpPrefixForce
setOutputFile
,
setDynOutputFile
,
setOutputHi
,
setDumpPrefixForce
::
Maybe
String
->
DynFlags
->
DynFlags
setObjectDir
f
d
=
d
{
objectDir
=
Just
f
}
...
...
@@ -1614,6 +1617,7 @@ setDynHiSuf f d = d{ dynHiSuf = f}
setHcSuf
f
d
=
d
{
hcSuf
=
f
}
setOutputFile
f
d
=
d
{
outputFile
=
f
}
setDynOutputFile
f
d
=
d
{
dynOutputFile
=
f
}
setOutputHi
f
d
=
d
{
outputHi
=
f
}
addPluginModuleName
::
String
->
DynFlags
->
DynFlags
...
...
@@ -1796,11 +1800,31 @@ parseDynamicFlagsFull activeFlags cmdline dflags0 args = do
throwGhcException
(
CmdLineError
(
"combination not supported: "
++
intercalate
"/"
(
map
wayDesc
theWays
)))
let
(
dflags4
,
consistency_warnings
)
=
makeDynFlagsConsistent
dflags3
-- TODO: This is an ugly hack. Do something better.
-- -fPIC affects the CMM code we generate, so if
-- we are in -dynamic-too mode we need -fPIC to be on during the
-- shared part of the compilation.
let
doingDynamicToo
=
gopt
Opt_BuildDynamicToo
dflags3
platform
=
targetPlatform
dflags3
dflags4
=
if
doingDynamicToo
then
foldr
setGeneralFlag'
dflags3
(
wayGeneralFlags
platform
WayDyn
)
else
dflags3
liftIO
$
setUnsafeGlobalDynFlags
dflags4
{-
TODO: This test doesn't quite work: We don't want to give an error
when e.g. compiling a C file, only when compiling Haskell files.
when doingDynamicToo $
unless (isJust (outputFile dflags4) == isJust (dynOutputFile dflags4)) $
throwGhcException $ CmdLineError
"With -dynamic-too, must give -dyno iff giving -o"
-}
return
(
dflags4
,
leftover
,
consistency_warnings
++
sh_warns
++
warns
)
let
(
dflags5
,
consistency_warnings
)
=
makeDynFlagsConsistent
dflags4
liftIO
$
setUnsafeGlobalDynFlags
dflags5
return
(
dflags5
,
leftover
,
consistency_warnings
++
sh_warns
++
warns
)
updateWays
::
DynFlags
->
DynFlags
updateWays
dflags
...
...
@@ -1992,6 +2016,7 @@ dynamic_flags = [
------- Output Redirection ------------------------------------------
,
Flag
"odir"
(
hasArg
setObjectDir
)
,
Flag
"o"
(
sepArg
(
setOutputFile
.
Just
))
,
Flag
"dyno"
(
sepArg
(
setDynOutputFile
.
Just
))
,
Flag
"ohi"
(
hasArg
(
setOutputHi
.
Just
))
,
Flag
"osuf"
(
hasArg
setObjectSuf
)
,
Flag
"dynosuf"
(
hasArg
setDynObjectSuf
)
...
...
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