[project @ 2002-05-01 17:56:52 by sof]

[ghc-hetmet.git] / ghc / compiler / main / DriverPipeline.hs

diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index ec45002..b567817 100644 (file)
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -44,6 +44,9 @@ import CmdLineOpts
 import Config
 import Panic
 import Util
+import Maybes          ( expectJust )
+
+import ParserCoreUtils ( getCoreModuleName )
 
 #ifdef GHCI
 import Time            ( getClockTime )
@@ -152,6 +155,11 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix)
                | split           -> not_valid
                | otherwise       -> [ Hsc, HCc, As ]
 
+       HscCore | split && mangle -> [ Hsc, HCc, Mangle, SplitMangle, SplitAs ]
+               | mangle          -> [ Hsc, HCc, Mangle, As ]
+               | split           -> not_valid
+               | otherwise       -> [ Hsc, HCc, As ]
+
        HscAsm  | split           -> [ Hsc, SplitMangle, SplitAs ]
                | otherwise       -> [ Hsc, As ]
 
@@ -187,9 +195,12 @@ genPipeline todo stop_flag persistent_output lang (filename,suffix)
        -- 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).
+--   hPutStrLn stderr (show ((start_phase `elem` pipeline,stop_phase /= Ln,stop_phase `notElem` pipeline), start_phase, stop_phase, pipeline,todo))
+--   hFlush stderr
    when (start_phase `elem` pipeline && 
         (stop_phase /= Ln && stop_phase `notElem` pipeline))
-        (throwDyn (UsageError 
+        (do
+         throwDyn (UsageError 
                    ("flag `" ++ stop_flag
                     ++ "' is incompatible with source file `"
                     ++ filename ++ "'" ++ show pipeline ++ show stop_phase)))
@@ -506,7 +517,14 @@ run_phase Hsc basename suff input_fn output_fn
        writeIORef v_HCHeader cc_injects
 
   -- gather the imports and module name
-        (srcimps,imps,mod_name) <- getImportsFromFile input_fn
+        (srcimps,imps,mod_name) <- 
+            if extcoreish_suffix suff
+            then do
+               -- no explicit imports in ExtCore input.
+              m <- getCoreModuleName input_fn
+              return ([], [], mkModuleName m)
+            else 
+              getImportsFromFile input_fn
 
   -- build a ModuleLocation to pass to hscMain.
        (mod, location')
@@ -529,10 +547,13 @@ run_phase Hsc basename suff input_fn output_fn
        do_recomp   <- readIORef v_Recomp
        todo        <- readIORef v_GhcMode
        expl_o_file <- readIORef v_Output_file
-        let o_file = 
-               case expl_o_file of
-                 Nothing -> unJust "source_unchanged" (ml_obj_file location)
-                 Just x  -> x
+
+       let o_file -- if the -o option is given and IT IS THE OBJECT FILE FOR
+                  -- THIS COMPILATION, then use that to determine if the 
+                  -- source is unchanged.
+               | Just x <- expl_o_file, todo == StopBefore Ln  =  x
+               | otherwise = expectJust "source_unchanged" (ml_obj_file location)
+
        source_unchanged <- 
           if not (do_recomp && ( todo == DoLink || todo == StopBefore Ln ))
             then return False
@@ -851,7 +872,7 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
 -- Complain about non-dynamic flags in OPTIONS pragmas
 
 checkProcessArgsResult flags basename suff
-  = do when (not (null flags)) (throwDyn (ProgramError (
+  = do when (notNull flags) (throwDyn (ProgramError (
            basename ++ "." ++ suff 
            ++ ": static flags are not allowed in {-# OPTIONS #-} pragmas:\n\t" 
            ++ unwords flags)) (ExitFailure 1))
@@ -1051,8 +1072,8 @@ compile ghci_mode summary source_unchanged have_object
 
    let verb      = verbosity dyn_flags
    let location   = ms_location summary
-   let input_fn   = unJust "compile:hs" (ml_hs_file location) 
-   let input_fnpp = unJust "compile:hspp" (ml_hspp_file location)
+   let input_fn   = expectJust "compile:hs" (ml_hs_file location) 
+   let input_fnpp = expectJust "compile:hspp" (ml_hspp_file location)
 
    when (verb >= 2) (hPutStrLn stderr ("compile: input file " ++ input_fnpp))