[commit: ghc] master: Make "happensBefore" take account of whether we are unregisterised (68833e5)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/68833e5e8caa1c23f75ab8bea4377ede28ff9548

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

commit 68833e5e8caa1c23f75ab8bea4377ede28ff9548
Author: Ian Lynagh <ian at well-typed.com>
Date:   Fri Jan 11 18:42:40 2013 +0000

    Make "happensBefore" take account of whether we are unregisterised
    
    If we are not unregisterised then we skip the HCc phase.
    Fixes #7563.

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

 compiler/main/DriverPhases.hs   |   61 +++++++++++++++++++++-----------------
 compiler/main/DriverPipeline.hs |   11 ++++---
 2 files changed, 40 insertions(+), 32 deletions(-)

diff --git a/compiler/main/DriverPhases.hs b/compiler/main/DriverPhases.hs
index a1eac53..2de19b9 100644
--- a/compiler/main/DriverPhases.hs
+++ b/compiler/main/DriverPhases.hs
@@ -35,6 +35,7 @@ module DriverPhases (
 
 #include "HsVersions.h"
 
+import {-# SOURCE #-} DynFlags
 import Outputable
 import Platform
 import System.FilePath
@@ -131,33 +132,39 @@ 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).
-happensBefore :: Phase -> Phase -> Bool
-StopLn `happensBefore` _ = False
-x      `happensBefore` y = after_x `eqPhase` y || after_x `happensBefore` y
-        where
-          after_x = nextPhase x
+happensBefore :: DynFlags -> Phase -> Phase -> Bool
+happensBefore dflags p1 p2 = p1 `happensBefore'` p2
+    where StopLn `happensBefore'` _ = False
+          x      `happensBefore'` y = after_x `eqPhase` y
+                                   || after_x `happensBefore'` y
+              where after_x = nextPhase dflags x
 
-nextPhase :: Phase -> Phase
--- A conservative approximation to the next phase, used in happensBefore
-nextPhase (Unlit sf) = Cpp  sf
-nextPhase (Cpp   sf) = HsPp sf
-nextPhase (HsPp  sf) = Hsc  sf
-nextPhase (Hsc   _)  = HCc
-nextPhase Splitter   = SplitAs
-nextPhase LlvmOpt    = LlvmLlc
-nextPhase LlvmLlc    = LlvmMangle
-nextPhase LlvmMangle = As
-nextPhase SplitAs    = MergeStub
-nextPhase As         = MergeStub
-nextPhase Ccpp       = As
-nextPhase Cc         = As
-nextPhase Cobjc      = As
-nextPhase Cobjcpp    = As
-nextPhase CmmCpp     = Cmm
-nextPhase Cmm        = HCc
-nextPhase HCc        = As
-nextPhase MergeStub  = StopLn
-nextPhase StopLn     = panic "nextPhase: nothing after StopLn"
+nextPhase :: DynFlags -> Phase -> Phase
+nextPhase dflags p
+    -- A conservative approximation to the next phase, used in happensBefore
+    = case p of
+      Unlit sf   -> Cpp  sf
+      Cpp   sf   -> HsPp sf
+      HsPp  sf   -> Hsc  sf
+      Hsc   _    -> maybeHCc
+      Splitter   -> SplitAs
+      LlvmOpt    -> LlvmLlc
+      LlvmLlc    -> LlvmMangle
+      LlvmMangle -> As
+      SplitAs    -> MergeStub
+      As         -> MergeStub
+      Ccpp       -> As
+      Cc         -> As
+      Cobjc      -> As
+      Cobjcpp    -> As
+      CmmCpp     -> Cmm
+      Cmm        -> maybeHCc
+      HCc        -> As
+      MergeStub  -> StopLn
+      StopLn     -> panic "nextPhase: nothing after StopLn"
+    where maybeHCc = if platformUnregisterised (targetPlatform dflags)
+                     then HCc
+                     else As
 
 -- the first compilation phase for a given file is determined
 -- by its suffix.
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 4c44a9c..e6a0623 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -540,7 +540,8 @@ runPipeline stop_phase hsc_env0 (input_fn, mb_phase)
          -- There is a partial ordering on phases, where A < B iff A occurs
          -- before B in a normal compilation pipeline.
 
-         when (not (start_phase `happensBefore` stop_phase)) $
+         let happensBefore' = happensBefore dflags
+         when (not (start_phase `happensBefore'` stop_phase)) $
                throwGhcException (UsageError
                            ("cannot compile this file to desired target: "
                               ++ input_fn))
@@ -682,12 +683,13 @@ phaseOutputFilename next_phase = do
 pipeLoop :: Phase -> FilePath -> CompPipeline FilePath
 pipeLoop phase input_fn = do
   PipeEnv{stop_phase} <- getPipeEnv
-  PipeState{hsc_env}  <- getPipeState
+  dflags <- getDynFlags
+  let happensBefore' = happensBefore dflags
   case () of
    _ | phase `eqPhase` stop_phase            -- All done
      -> return input_fn
 
-     | not (phase `happensBefore` stop_phase)
+     | not (phase `happensBefore'` stop_phase)
         -- Something has gone wrong.  We'll try to cover all the cases when
         -- this could happen, so if we reach here it is a panic.
         -- eg. it might happen if the -C flag is used on a source file that
@@ -696,9 +698,8 @@ pipeLoop phase input_fn = do
            " but I wanted to stop at phase " ++ show stop_phase)
 
      | otherwise
-     -> do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4
+     -> do liftIO $ debugTraceMsg dflags 4
                                   (ptext (sLit "Running phase") <+> ppr phase)
-           dflags <- getDynFlags
            (next_phase, output_fn) <- runPhase phase input_fn dflags
            pipeLoop next_phase output_fn