From: simonmar <unknown>
Date: Wed, 3 Jan 2001 11:13:43 +0000 (+0000)
Subject: [project @ 2001-01-03 11:13:43 by simonmar]
X-Git-Tag: Approximately_9120_patches~2986
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f4a6a4134b8ba3f2fc7a193ed5b91313046b775a;p=ghc-hetmet.git

[project @ 2001-01-03 11:13:43 by simonmar]
Hopefully fix the driver problems I introduced yesterday.
---

diff --git a/ghc/compiler/main/DriverPhases.hs b/ghc/compiler/main/DriverPhases.hs
index cab7b60..80c2b44 100644
--- a/ghc/compiler/main/DriverPhases.hs
+++ b/ghc/compiler/main/DriverPhases.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.3 2000/11/16 16:23:04 sewardj Exp $
+-- $Id: DriverPhases.hs,v 1.4 2001/01/03 11:13:43 simonmar Exp $
 --
 -- GHC Driver
 --
@@ -53,7 +53,7 @@ data Phase
 -- by its suffix.
 startPhase "lhs"   = Unlit
 startPhase "hs"    = Cpp
-startPhase "hspp"  = Hsc	-- not sure this will work ...
+startPhase "hspp"  = Hsc
 startPhase "hc"    = HCc
 startPhase "c"     = Cc
 startPhase "raw_s" = Mangle
@@ -66,7 +66,7 @@ startPhase _       = Ln	   -- all unknown file types
 -- the input requirements of the next phase.
 phaseInputExt Unlit       = "lhs"
 phaseInputExt Cpp         = "lpp"	-- intermediate only
-phaseInputExt Hsc         = "hspp"	-- intermediate only
+phaseInputExt Hsc         = "hspp"
 phaseInputExt HCc         = "hc"
 phaseInputExt Cc          = "c"
 phaseInputExt Mangle      = "raw_s"
@@ -76,7 +76,7 @@ phaseInputExt SplitAs     = "split_s"   -- not really generated
 phaseInputExt Ln          = "o"
 phaseInputExt MkDependHS  = "dep"
 
-haskellish_suffix = (`elem` [ "hs", "lhs", "hc" ])
+haskellish_suffix = (`elem` [ "hs", "hspp", "lhs", "hc" ])
 cish_suffix       = (`elem` [ "c", "s", "S" ])  -- maybe .cc et al.??
 
 haskellish_file f = haskellish_suffix suf where (_,suf) = splitFilename f
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index 5371181..810d1be 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.44 2000/12/20 15:44:29 rrt Exp $
+-- $Id: DriverPipeline.hs,v 1.45 2001/01/03 11:13:43 simonmar Exp $
 --
 -- GHC Driver
 --
@@ -13,7 +13,7 @@ module DriverPipeline (
 
 	-- interfaces for the batch-mode driver
    GhcMode(..), getGhcMode, v_GhcMode,
-   genPipeline, runPipeline,
+   genPipeline, runPipeline, pipeLoop,
 
 	-- interfaces for the compilation manager (interpreted/batch-mode)
    preprocess, compile, CompResult(..),
@@ -189,18 +189,6 @@ genPipeline todo stop_flag persistent_output lang filename
 				    ++ filename))
 	else do
 
-	-- if we can't find the phase we're supposed to stop before,
-	-- something has gone wrong.
-   case todo of
-	StopBefore phase -> 
-	   when (phase /= Ln 
-		 && phase `notElem` pipeline
-	   	 && not (phase == As && SplitAs `elem` pipeline)) $
-	      throwDyn (OtherError 
-		("flag " ++ stop_flag
-		 ++ " is incompatible with source file `" ++ filename ++ "'"))
-	_ -> return ()
-
    let
    ----------- -----  ----   ---   --   --  -  -  -
       myPhaseInputExt Ln = case osuf of Nothing -> phaseInputExt Ln
@@ -242,10 +230,22 @@ genPipeline todo stop_flag persistent_output lang filename
       phase_ne p (p1,_,_) = (p1 /= p)
    ----------- -----  ----   ---   --   --  -  -  -
 
-   return $
-     dropWhile (phase_ne start_phase) . 
-	foldr (\p ps -> if phase_ne stop_phase p then p:ps else [])  []
-		$ annotated_pipeline
+	-- if we can't find the phase we're supposed to stop before,
+	-- something has gone wrong.  This test carefully avoids the
+	-- case where we aren't supposed to do any compilation, because the file
+	-- is already in linkable form (for example).
+   if start_phase `elem` pipeline && 
+ 	(stop_phase /= Ln && stop_phase `notElem` pipeline)
+      then throwDyn (OtherError 
+		("flag " ++ stop_flag
+		 ++ " is incompatible with source file `" ++ filename ++ "'"))
+      else do
+
+   return (
+     takeWhile (phase_ne stop_phase ) $
+     dropWhile (phase_ne start_phase) $
+     annotated_pipeline
+    )
 
 
 runPipeline
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 3f81b88..5f5024a 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -fno-warn-incomplete-patterns #-}
 -----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.42 2001/01/02 15:30:57 simonmar Exp $
+-- $Id: Main.hs,v 1.43 2001/01/03 11:13:43 simonmar Exp $
 --
 -- GHC Driver program
 --
@@ -264,8 +264,6 @@ main =
 
    if null srcs then throwDyn (UsageError "no input files") else do
 
-   let lang = hscLang init_dyn_flags
-
    let compileFile src = do
 	  writeIORef v_Driver_state saved_driver_state
 	  writeIORef v_DynFlags init_dyn_flags
@@ -273,17 +271,20 @@ main =
 	  -- We compile in two stages, because the file may have an
 	  -- OPTIONS pragma that affects the compilation pipeline (eg. -fvia-C)
 
-	  -- preprocess
+	  let (basename, suffix) = splitFilename src
+
+	  -- just preprocess
 	  pp <- if mode == StopBefore Hsc then return src else do
-		phases <- genPipeline (StopBefore Hsc) "none" 
+		phases <- genPipeline (StopBefore Hsc) stop_flag
 			    False{-not persistent-} defaultHscLang src
-	  	runPipeline phases src False{-no linking-} False{-no -o flag-}
+	  	pipeLoop phases src False{-no linking-} False{-no -o flag-}
+			basename suffix
 
-	  -- compile
+	  -- rest of compilation
 	  dyn_flags <- readIORef v_DynFlags
 	  phases <- genPipeline mode stop_flag True (hscLang dyn_flags) pp
-	  r <- runPipeline phases pp False{-no linking-} False{-no -o flag-}
-
+	  r <- pipeLoop phases pp (mode==DoLink) True{-use -o flag-}
+			basename suffix
 	  return r
 
    o_files <- mapM compileFile srcs