diff options
| -rw-r--r-- | compiler/main/DriverPipeline.hs | 53 | ||||
| -rw-r--r-- | 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 57b0432207..840a0470e2 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 47543aed51..7b90623fef 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 ----------------------------------------------------------------------------- |