[commit: ghc] master: Don't throw exception when start_phase==stop_phase (#10219) (6981862)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/698186268d3846c9984798ab32f34f83f3c2337e/ghc

>---------------------------------------------------------------

commit 698186268d3846c9984798ab32f34f83f3c2337e
Author: Thomas Miedema <thomasmiedema at gmail.com>
Date:   Tue Mar 31 12:12:24 2015 +0200

    Don't throw exception when start_phase==stop_phase (#10219)
    
    Just do nothing instead. This bug only shows up when using `-x hspp` in
    --make mode on registerised builds.
    
    Reviewed By: austin
    
    Differential Revision: https://phabricator.haskell.org/D776


>---------------------------------------------------------------

698186268d3846c9984798ab32f34f83f3c2337e
 compiler/main/DriverPhases.hs                   | 19 ++++++++++++++++---
 compiler/main/DriverPipeline.hs                 | 10 +++++-----
 testsuite/tests/driver/{T703.hs => T10219.hspp} |  0
 testsuite/tests/driver/all.T                    |  5 +++++
 4 files changed, 26 insertions(+), 8 deletions(-)

diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index 164de4c..f1db9bc 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -165,9 +165,22 @@ eqPhase Ccxx        Ccxx       = True
 eqPhase Cobjcxx     Cobjcxx    = True
 eqPhase _           _          = False
 
--- Partial ordering on phases: we want to know which phases will occur before
--- which others.  This is used for sanity checking, to ensure that the
--- pipeline will stop at some point (see DriverPipeline.runPipeline).
+{- Note [Partial ordering on phases]
+
+We want to know which phases will occur before which others. This is used for
+sanity checking, to ensure that the pipeline will stop at some point (see
+DriverPipeline.runPipeline).
+
+A < B iff A occurs before B in a normal compilation pipeline.
+
+There is explicitly not a total ordering on phases, because in registerised
+builds, the phase `HsC` doesn't happen before nor after any other phase.
+
+Although we check that a normal user doesn't set the stop_phase to HsC through
+use of -C with registerised builds (in Main.checkOptions), it is still
+possible for a ghc-api user to do so. So be careful when using the function
+happensBefore, and don't think that `not (a <= b)` implies `b < a`.
+-}
 happensBefore :: DynFlags -> Phase -> Phase -> Bool
 happensBefore dflags p1 p2 = p1 `happensBefore'` p2
     where StopLn `happensBefore'` _ = False
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 334c151..498b2f0 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -606,14 +606,13 @@ runPipeline stop_phase hsc_env0 (input_fn, 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.
-         --
-         -- There is a partial ordering on phases, where A < B iff A occurs
-         -- before B in a normal compilation pipeline.
-
          let happensBefore' = happensBefore dflags
          case start_phase of
              RealPhase start_phase' ->
-                 when (not (start_phase' `happensBefore'` stop_phase)) $
+                 -- See Note [Partial ordering on phases]
+                 -- Not the same as: (stop_phase `happensBefore` start_phase')
+                 when (not (start_phase' `happensBefore'` stop_phase ||
+                            start_phase' `eqPhase` stop_phase)) $
                        throwGhcExceptionIO (UsageError
                                    ("cannot compile this file to desired target: "
                                       ++ input_fn))
@@ -663,6 +662,7 @@ pipeLoop :: PhasePlus -> FilePath -> CompPipeline (DynFlags, FilePath)
 pipeLoop phase input_fn = do
   env <- getPipeEnv
   dflags <- getDynFlags
+  -- See Note [Partial ordering on phases]
   let happensBefore' = happensBefore dflags
       stopPhase = stop_phase env
   case phase of
diff --git a/testsuite/tests/driver/T703.hs b/testsuite/tests/driver/T10219.hspp
similarity index 100%
copy from testsuite/tests/driver/T703.hs
copy to testsuite/tests/driver/T10219.hspp
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index 0585c9c..e1665f1 100644
--- a/testsuite/tests/driver/all.T
+++ b/testsuite/tests/driver/all.T
@@ -422,3 +422,8 @@ test('T9938B',
 
 test('T9963', exit_code(1), run_command,
      ['{compiler} --interactive --print-libdir'])
+
+test('T10219', normal, run_command,
+     # `-x hspp` in make mode should work.
+     # Note: need to specify `-x hspp` before the filename.
+     ['{compiler} --make -x hspp T10219.hspp -fno-code -v0'])