Commit 96ea76c7 authored by ian@well-typed.com's avatar ian@well-typed.com

dynamic-too progress

parent 35428a3a
......@@ -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
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment