Warning fix for unused and redundant imports
[ghc-hetmet.git] / compiler / main / DriverPipeline.hs
index 59f0721..16a1725 100644 (file)
@@ -29,8 +29,7 @@ module DriverPipeline (
 import Packages
 import HeaderInfo
 import DriverPhases
-import SysTools                ( newTempName, addFilesToClean, copy )
-import qualified SysTools      
+import SysTools
 import HscMain
 import Finder
 import HscTypes
@@ -60,7 +59,6 @@ import Control.Monad
 import Data.List       ( isSuffixOf )
 import Data.Maybe
 import System.Exit
-import System.Cmd
 import System.Environment
 
 -- ---------------------------------------------------------------------------
@@ -75,7 +73,8 @@ import System.Environment
 preprocess :: DynFlags -> (FilePath, Maybe Phase) -> IO (DynFlags, FilePath)
 preprocess dflags (filename, mb_phase) =
   ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) 
-  runPipeline anyHsc dflags (filename, mb_phase) Temporary Nothing{-no ModLocation-}
+  runPipeline anyHsc dflags (filename, mb_phase) 
+        Nothing Temporary Nothing{-no ModLocation-}
 
 -- ---------------------------------------------------------------------------
 -- Compile
@@ -169,7 +168,9 @@ compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do
                             -> return ([], ms_hs_date mod_summary)
                           -- We're in --make mode: finish the compilation pipeline.
                           _other
-                            -> do runPipeline StopLn dflags (output_fn,Nothing) Persistent
+                            -> do runPipeline StopLn dflags (output_fn,Nothing)
+                                              (Just basename)
+                                              Persistent
                                               (Just location)
                                   -- The object filename comes from the ModLocation
                                   o_time <- getModificationTime object_filename
@@ -238,7 +239,7 @@ compileStub dflags mod location = do
 
        -- compile the _stub.c file w/ gcc
        let (stub_c,_) = mkStubPaths dflags (moduleName mod) location
-       runPipeline StopLn dflags (stub_c,Nothing) 
+       runPipeline StopLn dflags (stub_c,Nothing)  Nothing
                (SpecificFile stub_o) Nothing{-no ModLocation-}
 
        return stub_o
@@ -247,7 +248,7 @@ compileStub dflags mod location = do
 -- ---------------------------------------------------------------------------
 -- Link
 
-link :: GhcMode                        -- interactive or batch
+link :: GhcLink                        -- interactive or batch
      -> DynFlags               -- dynamic flags
      -> Bool                   -- attempt linking in batch mode?
      -> HomePackageTable       -- what to link
@@ -261,15 +262,15 @@ link :: GhcMode                   -- interactive or batch
 -- will succeed.
 
 #ifdef GHCI
-link Interactive dflags batch_attempt_linking hpt
+link LinkInMemory dflags batch_attempt_linking hpt
     = do -- Not Linking...(demand linker will do the job)
         return Succeeded
 #endif
 
-link JustTypecheck dflags batch_attempt_linking hpt
+link NoLink dflags batch_attempt_linking hpt
    = return Succeeded
 
-link BatchCompile dflags batch_attempt_linking hpt
+link LinkBinary dflags batch_attempt_linking hpt
    | batch_attempt_linking
    = do 
        let 
@@ -314,7 +315,7 @@ link BatchCompile dflags batch_attempt_linking hpt
        -- Don't showPass in Batch mode; doLink will do that for us.
        let link = case ghcLink dflags of
                MkDLL       -> doMkDLL
-               StaticLink  -> staticLink
+               LinkBinary  -> staticLink
        link dflags obj_files pkg_deps
 
         debugTraceMsg dflags 3 (text "link: done")
@@ -361,7 +362,8 @@ compileFile dflags stop_phase (src, mb_phase) = do
                        other      -> stop_phase
 
    (_, out_file) <- runPipeline stop_phase' dflags
-                         (src, mb_phase) output Nothing{-no ModLocation-}
+                         (src, mb_phase) Nothing output 
+                          Nothing{-no ModLocation-}
    return out_file
 
 
@@ -373,7 +375,7 @@ doLink dflags stop_phase o_files
   | otherwise
   = case ghcLink dflags of
        NoLink     -> return ()
-       StaticLink -> staticLink dflags o_files link_pkgs
+       LinkBinary -> staticLink dflags o_files link_pkgs
        MkDLL      -> doMkDLL dflags o_files link_pkgs
   where
    -- Always link in the haskell98 package for static linking.  Other
@@ -407,13 +409,16 @@ runPipeline
   :: Phase                     -- When to stop
   -> DynFlags                  -- Dynamic flags
   -> (FilePath,Maybe Phase)     -- Input filename (and maybe -x suffix)
+  -> Maybe FilePath             -- original basename (if different from ^^^)
   -> PipelineOutput            -- Output filename
   -> Maybe ModLocation          -- A ModLocation, if this is a Haskell module
   -> IO (DynFlags, FilePath)   -- (final flags, output filename)
 
-runPipeline stop_phase dflags (input_fn, mb_phase) output maybe_loc
+runPipeline stop_phase dflags (input_fn, mb_phase) mb_basename output maybe_loc
   = do
-  let (basename, suffix) = splitFilename input_fn
+  let (input_basename, suffix) = splitFilename input_fn
+      basename | Just b <- mb_basename = b
+               | otherwise             = input_basename
 
        -- If we were given a -x flag, then use that phase to start from
       start_phase = fromMaybe (startPhase suffix) mb_phase
@@ -442,17 +447,19 @@ runPipeline stop_phase dflags (input_fn, mb_phase) output maybe_loc
   -- Sometimes, a compilation phase doesn't actually generate any output
   -- (eg. the CPP phase when -fcpp is not turned on).  If we end on this
   -- stage, but we wanted to keep the output, then we have to explicitly
-  -- copy the file.
+  -- copy the file, remembering to prepend a {-# LINE #-} pragma so that
+  -- further compilation stages can tell what the original filename was.
   case output of
     Temporary -> 
        return (dflags', output_fn)
     _other ->
        do final_fn <- get_output_fn dflags' stop_phase maybe_loc
-          when (final_fn /= output_fn) $
-                 copy dflags ("Copying `" ++ output_fn ++ "' to `" ++ final_fn
-                       ++ "'") output_fn final_fn
+          when (final_fn /= output_fn) $ do
+              let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'")
+                  line_prag = Just ("{-# LINE 1 \"" ++ input_fn ++ "\" #-}\n")
+             copyWithHeader dflags msg line_prag output_fn final_fn
           return (dflags', final_fn)
-               
+
 
 
 pipeLoop :: DynFlags -> Phase -> Phase 
@@ -1057,9 +1064,9 @@ runPhase_MoveBinary dflags input_fn
            pvm_executable_base = "=" ++ input_fn
            pvm_executable = pvm_root ++ "/bin/" ++ pvm_arch ++ "/" ++ pvm_executable_base
         -- nuke old binary; maybe use configur'ed names for cp and rm?
-        system ("rm -f " ++ pvm_executable)
+        Panic.try (removeFile pvm_executable)
         -- move the newly created binary into PVM land
-        system ("cp -p " ++ input_fn ++ " " ++ pvm_executable)
+        copy dflags "copying PVM executable" input_fn pvm_executable
         -- generate a wrapper script for running a parallel prg under PVM
         writeFile input_fn (mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan)
        return True
@@ -1097,18 +1104,18 @@ mk_pvm_wrapper_script pvm_executable pvm_executable_base sysMan = unlines $
   "",
   "args: while ($a = shift(@ARGV)) {",
   "    if ( $a eq '+RTS' ) {",
-  "    $in_RTS_args = 1;",
+  "        $in_RTS_args = 1;",
   "    } elsif ( $a eq '-RTS' ) {",
-  "    $in_RTS_args = 0;",
+  "        $in_RTS_args = 0;",
   "    }",
   "    if ( $a eq '-d' && $in_RTS_args ) {",
-  "    $debug = '-';",
+  "        $debug = '-';",
   "    } elsif ( $a =~ /^-qN(\\d+)/ && $in_RTS_args ) {",
-  "    $nprocessors = $1;",
+  "        $nprocessors = $1;",
   "    } elsif ( $a =~ /^-qp(\\d+)/ && $in_RTS_args ) {",
-  "    $nprocessors = $1;",
+  "        $nprocessors = $1;",
   "    } else {",
-  "    push(@nonPVM_args, $a);",
+  "        push(@nonPVM_args, $a);",
   "    }",
   "}",
   "",