[commit: ghc] master: Fix "-dynamic-too --make"; fixes #7864 (25dd77f)
Ian Lynagh
igloo at earth.li
Fri Apr 26 21:42:32 CEST 2013
Repository : http://darcs.haskell.org/ghc.git/
On branch : master
https://github.com/ghc/ghc/commit/25dd77f545316dd2947890e7896c06736fa7fe44
>---------------------------------------------------------------
commit 25dd77f545316dd2947890e7896c06736fa7fe44
Author: Ian Lynagh <ian at well-typed.com>
Date: Fri Apr 26 19:40:36 2013 +0100
Fix "-dynamic-too --make"; fixes #7864
>---------------------------------------------------------------
compiler/main/DriverPipeline.hs | 53 +++++++++++++++++++++--------------------
compiler/main/DynFlags.hs | 3 ++-
2 files changed, 29 insertions(+), 27 deletions(-)
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 57b0432..840a047 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -78,7 +78,7 @@ preprocess :: HscEnv
-> IO (DynFlags, FilePath)
preprocess hsc_env (filename, mb_phase) =
ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename)
- runPipeline anyHsc hsc_env (filename, mb_phase)
+ runPipeline anyHsc hsc_env (filename, fmap RealPhase mb_phase)
Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-}
-- ---------------------------------------------------------------------------
@@ -234,19 +234,16 @@ compileOne' m_tc_result mHscMessage
guts <- hscSimplify hsc_env' guts0
(iface, changed, details, cgguts) <- hscNormalIface hsc_env' guts mb_old_hash
hscWriteIface dflags' iface changed summary
- (_outputFilename, hasStub) <- hscGenHardCode hsc_env' cgguts summary
-- We're in --make mode: finish the compilation pipeline.
- maybe_stub_o <- case hasStub of
- Nothing -> return Nothing
- Just stub_c -> do
- stub_o <- compileStub hsc_env' stub_c
- return (Just stub_o)
- _ <- runPipeline StopLn hsc_env' (output_fn,Nothing)
+ let mod_name = ms_mod_name summary
+ _ <- runPipeline StopLn hsc_env'
+ (output_fn,
+ Just (HscOut src_flavour mod_name (HscRecomp cgguts summary)))
(Just basename)
Persistent
(Just location)
- maybe_stub_o
+ Nothing
-- The object filename comes from the ModLocation
o_time <- getModificationUTCTime object_filename
let linkable = LM o_time this_mod [DotO object_filename]
@@ -475,7 +472,7 @@ compileFile hsc_env stop_phase (src, mb_phase) = do
_ -> stop_phase
( _, out_file) <- runPipeline stop_phase' hsc_env
- (src, mb_phase) Nothing output
+ (src, fmap RealPhase mb_phase) Nothing output
Nothing{-no ModLocation-} Nothing
return out_file
@@ -521,12 +518,12 @@ data PipelineOutput
runPipeline
:: Phase -- ^ When to stop
-> HscEnv -- ^ Compilation environment
- -> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix)
+ -> (FilePath,Maybe PhasePlus) -- ^ Input filename (and maybe -x suffix)
-> Maybe FilePath -- ^ original basename (if different from ^^^)
-> PipelineOutput -- ^ Output filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> Maybe FilePath -- ^ stub object, if we have one
- -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
+ -> IO (DynFlags, FilePath) -- ^ (final flags, output filename)
runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
mb_basename output maybe_loc maybe_stub_o
@@ -543,13 +540,14 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
| otherwise = input_basename
-- If we were given a -x flag, then use that phase to start from
- start_phase = fromMaybe (startPhase suffix') mb_phase
+ start_phase = fromMaybe (RealPhase (startPhase suffix')) mb_phase
- isHaskell (Unlit _) = True
- isHaskell (Cpp _) = True
- isHaskell (HsPp _) = True
- isHaskell (Hsc _) = True
- isHaskell _ = False
+ isHaskell (RealPhase (Unlit _)) = True
+ isHaskell (RealPhase (Cpp _)) = True
+ isHaskell (RealPhase (HsPp _)) = True
+ isHaskell (RealPhase (Hsc _)) = True
+ isHaskell (HscOut {}) = True
+ isHaskell _ = False
isHaskellishFile = isHaskell start_phase
@@ -568,10 +566,13 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
-- before B in a normal compilation pipeline.
let happensBefore' = happensBefore dflags
- when (not (start_phase `happensBefore'` stop_phase)) $
- throwGhcExceptionIO (UsageError
- ("cannot compile this file to desired target: "
- ++ input_fn))
+ case start_phase of
+ RealPhase start_phase' ->
+ when (not (start_phase' `happensBefore'` stop_phase)) $
+ throwGhcExceptionIO (UsageError
+ ("cannot compile this file to desired target: "
+ ++ input_fn))
+ HscOut {} -> return ()
debugTraceMsg dflags 4 (text "Running the pipeline")
r <- runPipeline' start_phase hsc_env env input_fn
@@ -592,7 +593,7 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
return r
runPipeline'
- :: Phase -- ^ When to start
+ :: PhasePlus -- ^ When to start
-> HscEnv -- ^ Compilation environment
-> PipeEnv
-> FilePath -- ^ Input filename
@@ -605,7 +606,7 @@ runPipeline' start_phase hsc_env env input_fn
-- Execute the pipeline...
let state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o }
- evalP (pipeLoop (RealPhase start_phase) input_fn) env state
+ evalP (pipeLoop start_phase input_fn) env state
-- -----------------------------------------------------------------------------
-- The pipeline uses a monad to carry around various bits of information
@@ -722,12 +723,12 @@ pipeLoop phase input_fn = do
(ptext (sLit "Running phase") <+> ppr phase)
(next_phase, output_fn) <- runPhase phase input_fn dflags
r <- pipeLoop next_phase output_fn
- case next_phase of
+ case phase of
HscOut {} ->
whenGeneratingDynamicToo dflags $ do
setDynFlags $ doDynamicToo dflags
-- TODO shouldn't ignore result:
- _ <- pipeLoop next_phase output_fn
+ _ <- pipeLoop phase input_fn
return ()
_ ->
return ()
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 47543ae..7b90623 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1173,7 +1173,8 @@ doDynamicToo dflags0 = let dflags1 = addWay' WayDyn dflags0
objectSuf = dynObjectSuf dflags1
}
dflags3 = updateWays dflags2
- in dflags3
+ dflags4 = gopt_unset dflags3 Opt_BuildDynamicToo
+ in dflags4
-----------------------------------------------------------------------------
More information about the ghc-commits
mailing list