[commit: ghc] master: dynamic-too progress (96ea76c)
Ian Lynagh
igloo at earth.li
Fri Jan 11 14:04:21 CET 2013
Repository : ssh://darcs.haskell.org//srv/darcs/ghc
On branch : master
http://hackage.haskell.org/trac/ghc/changeset/96ea76c7afd6d61e499b936827e2212001065e90
>---------------------------------------------------------------
commit 96ea76c7afd6d61e499b936827e2212001065e90
Author: Ian Lynagh <ian at well-typed.com>
Date: Fri Jan 11 11:54:23 2013 +0000
dynamic-too progress
>---------------------------------------------------------------
compiler/main/DriverPipeline.hs | 34 ++++++++++++++++++++++++++++------
compiler/main/DynFlags.hs | 33 +++++++++++++++++++++++++++++----
2 files changed, 57 insertions(+), 10 deletions(-)
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 2073665..4c44a9c 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -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
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 3538629..45c9d64 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -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)
More information about the ghc-commits
mailing list