From 698186268d3846c9984798ab32f34f83f3c2337e Mon Sep 17 00:00:00 2001
From: Thomas Miedema <thomasmiedema@gmail.com>
Date: Tue, 31 Mar 2015 12:12:24 +0200
Subject: [PATCH] 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
---
 compiler/main/DriverPhases.hs      | 19 ++++++++++++++++---
 compiler/main/DriverPipeline.hs    | 10 +++++-----
 testsuite/tests/driver/T10219.hspp |  1 +
 testsuite/tests/driver/all.T       |  5 +++++
 4 files changed, 27 insertions(+), 8 deletions(-)
 create mode 100644 testsuite/tests/driver/T10219.hspp

diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index 164de4c75ab0..f1db9bc6ec14 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 334c15142d00..498b2f092143 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/T10219.hspp b/testsuite/tests/driver/T10219.hspp
new file mode 100644
index 000000000000..b3549c2fe3d7
--- /dev/null
+++ b/testsuite/tests/driver/T10219.hspp
@@ -0,0 +1 @@
+main = return ()
diff --git a/testsuite/tests/driver/all.T b/testsuite/tests/driver/all.T
index 0585c9c4aab3..e1665f1aca36 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'])