[project @ 2003-07-18 13:18:06 by simonmar]
[ghc-hetmet.git] / ghc / compiler / main / DriverPipeline.hs
index 2c20376..81ef08d 100644 (file)
@@ -75,6 +75,7 @@ preprocess filename =
        False{-temporary output file-}
        Nothing{-no specific output file-}
        filename
+       Nothing{-no ModLocation-}
 
 -- ---------------------------------------------------------------------------
 -- Compile
@@ -134,30 +135,18 @@ compile ghci_mode this_mod location
    processArgs dynamic_flags opts []
    dyn_flags <- getDynFlags
 
-   let hsc_lang      = hscLang dyn_flags
-       (basename, _) = splitFilename input_fn
+   let (basename, _) = splitFilename input_fn
        
-   keep_hc <- readIORef v_Keep_hc_files
-#ifdef ILX
-   keep_il <- readIORef v_Keep_il_files
-#endif
-   keep_s  <- readIORef v_Keep_s_files
-
-   output_fn <- 
-       case hsc_lang of
-          HscAsm  | keep_s    -> return (basename ++ '.':phaseInputExt As)
-                  | otherwise -> newTempName (phaseInputExt As)
-          HscC    | keep_hc   -> return (basename ++ '.':phaseInputExt HCc)
-                  | otherwise -> newTempName (phaseInputExt HCc)
-           HscJava             -> newTempName "java" -- ToDo
-#ifdef ILX
-          HscILX  | keep_il   -> return (basename ++ '.':phaseInputExt Ilasm)
-                   | otherwise -> newTempName (phaseInputExt Ilx2Il)   
-#endif
-          HscInterpreted      -> return (error "no output file")
-           HscNothing         -> return (error "no output file")
-
-   let dyn_flags' = dyn_flags { hscOutName = output_fn,
+   -- figure out what lang we're generating
+   hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
+   -- figure out what the next phase should be
+   next_phase <- hscNextPhase hsc_lang
+   -- figure out what file to generate the output into
+   get_output_fn <- genOutputFilenameFunc False Nothing next_phase basename
+   output_fn <- get_output_fn next_phase (Just location)
+
+   let dyn_flags' = dyn_flags { hscLang = hsc_lang,
+                               hscOutName = output_fn,
                                hscStubCOutName = basename ++ "_stub.c",
                                hscStubHOutName = basename ++ "_stub.h",
                                extCoreName = basename ++ ".hcr" }
@@ -208,7 +197,8 @@ compile ghci_mode this_mod location
                   createDirectoryHierarchy object_dir
 
                   runPipeline (StopBefore Ln) ""
-                       True (Just object_filename) output_fn
+                       True Nothing output_fn (Just location)
+                       -- the object filename comes from the ModLocation
 
                   o_time <- getModificationTime object_filename
                   return ([DotO object_filename], o_time)
@@ -230,6 +220,7 @@ compileStub dflags stub_c_exists
                        True{-persistent output-} 
                        Nothing{-no specific output file-}
                        stub_c
+                       Nothing{-no ModLocation-}
        return (Just stub_o)
 
 
@@ -310,9 +301,10 @@ runPipeline
   -> Bool              -- final output is persistent?
   -> Maybe FilePath    -- where to put the output, optionally
   -> FilePath          -- input filename
+  -> Maybe ModLocation  -- a ModLocation for this module, if we have one
   -> IO FilePath       -- output filename
 
-runPipeline todo stop_flag keep_output maybe_output_filename input_fn
+runPipeline todo stop_flag keep_output maybe_output_filename input_fn maybe_loc
   = do
   split <- readIORef v_Split_object_files
   let (basename, suffix) = splitFilename input_fn
@@ -344,15 +336,16 @@ runPipeline todo stop_flag keep_output maybe_output_filename input_fn
                        stop_phase basename
 
   -- and execute the pipeline...
-  output_fn <- pipeLoop start_phase stop_phase input_fn basename suffix 
-                get_output_fn
+  (output_fn, maybe_loc) <- 
+       pipeLoop start_phase stop_phase input_fn basename suffix 
+                get_output_fn 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.
   if keep_output
-       then do final_fn <- get_output_fn stop_phase
+       then do final_fn <- get_output_fn stop_phase maybe_loc
                when (final_fn /= output_fn) $
                  copy ("Copying `" ++ output_fn ++ "' to `" ++ final_fn
                        ++ "'") output_fn final_fn
@@ -362,24 +355,42 @@ runPipeline todo stop_flag keep_output maybe_output_filename input_fn
 
 
 pipeLoop :: Phase -> Phase -> FilePath -> String -> Suffix
-  -> (Phase -> IO FilePath) -> IO FilePath
-pipeLoop phase stop_phase input_fn orig_basename orig_suff get_output_fn
-  | phase == stop_phase  =  return input_fn  -- all done
+  -> (Phase -> Maybe ModLocation -> IO FilePath)
+  -> Maybe ModLocation -> IO (FilePath, Maybe ModLocation)
+
+pipeLoop phase stop_phase input_fn orig_basename orig_suff 
+       get_output_fn maybe_loc
+
+  | phase == stop_phase  =  return (input_fn, maybe_loc)  -- all done
+
+  | 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
+       -- has {-# OPTIONS -fasm #-}.
+       panic ("pipeLoop: at phase " ++ show phase ++ 
+               " but I wanted to stop at phase " ++ show stop_phase)
+
   | otherwise = do
        maybe_next_phase <- runPhase phase orig_basename orig_suff input_fn
-                               get_output_fn
+                               get_output_fn maybe_loc
        case maybe_next_phase of
-         (Nothing, output_fn) -> return output_fn
-         (Just next_phase, output_fn) -> 
+         (Nothing, maybe_loc, output_fn) -> do
+               -- we stopped early, but return the *final* filename
+               -- (it presumably already exists)
+               final_fn <- get_output_fn stop_phase maybe_loc
+               return (final_fn, maybe_loc)
+         (Just next_phase, maybe_loc, output_fn) ->
                pipeLoop next_phase stop_phase output_fn
-                       orig_basename orig_suff get_output_fn
+                       orig_basename orig_suff get_output_fn maybe_loc
 
   
 genOutputFilenameFunc :: Bool -> Maybe FilePath -> Phase -> String
-  -> IO (Phase{-next phase-} -> IO FilePath)
+  -> IO (Phase{-next phase-} -> Maybe ModLocation -> IO FilePath)
 genOutputFilenameFunc keep_output maybe_output_filename stop_phase basename
  = do
    hcsuf      <- readIORef v_HC_suf
+   odir       <- readIORef v_Output_dir
    osuf       <- readIORef v_Object_suf
    keep_hc    <- readIORef v_Keep_hc_files
 #ifdef ILX
@@ -393,16 +404,18 @@ genOutputFilenameFunc keep_output maybe_output_filename stop_phase basename
         myPhaseInputExt Ln    = osuf
         myPhaseInputExt other = phaseInputExt other
 
-       func next_phase
+       func next_phase maybe_location
                | next_phase == stop_phase
                      = case maybe_output_filename of
                             Just file -> return file
-                            Nothing | keep_output -> return persistent
-                                    | otherwise   -> newTempName suffix
+                            Nothing
+                                | Ln <- next_phase -> return odir_persistent
+                                | keep_output      -> return persistent
+                                | otherwise        -> newTempName suffix
                        -- sometimes, we keep output from intermediate stages
                | otherwise
                     = case next_phase of
-                            Ln                  -> return persistent
+                            Ln                  -> return odir_persistent
                             Mangle | keep_raw_s -> return persistent
                             As     | keep_s     -> return persistent
                             HCc    | keep_hc    -> return persistent
@@ -411,6 +424,11 @@ genOutputFilenameFunc keep_output maybe_output_filename stop_phase basename
                suffix = myPhaseInputExt next_phase
                persistent = basename ++ '.':suffix
 
+               odir_persistent
+                  | Just loc <- maybe_location = ml_obj_file loc
+                  | Just d <- odir = replaceFilenameDirectory persistent d
+                  | otherwise      = persistent
+
    return func
 
 
@@ -428,17 +446,20 @@ runPhase :: Phase
          -> String     -- basename of original input source
          -> String     -- its extension
          -> FilePath   -- name of file which contains the input to this phase.
-         -> (Phase -> IO FilePath)     -- how to calculate the output filename
-         -> IO (Maybe Phase,   -- next phase
-                FilePath)      -- output filename
+         -> (Phase -> Maybe ModLocation -> IO FilePath)
+                       -- how to calculate the output filename
+         -> Maybe ModLocation          -- the ModLocation, if we have one
+         -> IO (Maybe Phase,           -- next phase
+                Maybe ModLocation,     -- the ModLocation, if we have one
+                FilePath)              -- output filename
 
 -------------------------------------------------------------------------------
 -- Unlit phase 
 
-runPhase Unlit _basename _suff input_fn get_output_fn
+runPhase Unlit _basename _suff input_fn get_output_fn maybe_loc
   = do unlit_flags <- getOpts opt_L
        -- The -h option passes the file name for unlit to put in a #line directive
-       output_fn <- get_output_fn Cpp
+       output_fn <- get_output_fn Cpp maybe_loc
 
        SysTools.runUnlit (map SysTools.Option unlit_flags ++
                                  [ SysTools.Option     "-h"
@@ -447,12 +468,12 @@ runPhase Unlit _basename _suff input_fn get_output_fn
                          , SysTools.FileOption "" output_fn
                          ])
 
-       return (Just Cpp, output_fn)
+       return (Just Cpp, maybe_loc, output_fn)
 
 -------------------------------------------------------------------------------
 -- Cpp phase 
 
-runPhase Cpp basename suff input_fn get_output_fn
+runPhase Cpp basename suff input_fn get_output_fn maybe_loc
   = do src_opts <- getOptionsFromSource input_fn
        unhandled_flags <- processArgs dynamic_flags src_opts []
        checkProcessArgsResult unhandled_flags basename suff
@@ -461,7 +482,7 @@ runPhase Cpp basename suff input_fn get_output_fn
        if not do_cpp then
            -- no need to preprocess CPP, just pass input file along
           -- to the next phase of the pipeline.
-          return (Just HsPp, input_fn)
+          return (Just HsPp, maybe_loc, input_fn)
        else do
            hscpp_opts      <- getOpts opt_P
                    hs_src_cpp_opts <- readIORef v_Hs_source_cpp_opts
@@ -475,7 +496,7 @@ runPhase Cpp basename suff input_fn get_output_fn
            verb <- getVerbFlag
            (md_c_flags, _) <- machdepCCOpts
 
-           output_fn <- get_output_fn HsPp
+           output_fn <- get_output_fn HsPp maybe_loc
 
            SysTools.runCpp ([SysTools.Option verb]
                            ++ map SysTools.Option include_paths
@@ -497,22 +518,22 @@ runPhase Cpp basename suff input_fn get_output_fn
                               , SysTools.FileOption "" output_fn
                               ])
 
-           return (Just HsPp, output_fn)
+           return (Just HsPp, maybe_loc, output_fn)
 
 -------------------------------------------------------------------------------
 -- HsPp phase 
 
-runPhase HsPp basename suff input_fn get_output_fn
+runPhase HsPp basename suff input_fn get_output_fn maybe_loc
   = do do_pp   <- dynFlag ppFlag
        if not do_pp then
            -- no need to preprocess, just pass input file along
           -- to the next phase of the pipeline.
-          return (Just Hsc, input_fn)
+          return (Just Hsc, maybe_loc, input_fn)
        else do
            hspp_opts      <- getOpts opt_F
                    hs_src_pp_opts <- readIORef v_Hs_source_pp_opts
            let orig_fn = basename ++ '.':suff
-           output_fn <- get_output_fn Hsc
+           output_fn <- get_output_fn Hsc maybe_loc
            SysTools.runPp ( [ SysTools.Option     orig_fn
                             , SysTools.Option     input_fn
                             , SysTools.FileOption "" output_fn
@@ -520,18 +541,18 @@ runPhase HsPp basename suff input_fn get_output_fn
                             map SysTools.Option hs_src_pp_opts ++
                             map SysTools.Option hspp_opts
                           )
-           return (Just Hsc, output_fn)
+           return (Just Hsc, maybe_loc, output_fn)
 
 -----------------------------------------------------------------------------
 -- Hsc phase
 
 -- Compilation of a single module, in "legacy" mode (_not_ under
 -- the direction of the compilation manager).
-runPhase Hsc basename suff input_fn get_output_fn = do
+runPhase Hsc basename suff input_fn get_output_fn _maybe_loc = do
   todo <- readIORef v_GhcMode
   if todo == DoMkDependHS then do
-       doMkDependHSPhase basename suff input_fn
-       return (Nothing, input_fn)  -- Ln is a dummy stop phase 
+       locn <- doMkDependHSPhase basename suff input_fn
+       return (Nothing, Just locn, input_fn)  -- Ln is a dummy stop phase 
 
    else do
       -- normal Hsc mode, not mkdependHS
@@ -555,8 +576,7 @@ runPhase Hsc basename suff input_fn get_output_fn = do
               getImportsFromFile input_fn
 
   -- build a ModLocation to pass to hscMain.
-       let (path,file) = splitFilenameDir basename
-       (mod, location') <- mkHomeModLocation mod_name True path file suff
+       (mod, location') <- mkHomeModLocation mod_name (basename ++ '.':suff)
 
   -- take -ohi into account if present
        ohi <- readIORef v_Output_hi
@@ -595,18 +615,12 @@ runPhase Hsc basename suff input_fn get_output_fn = do
 
   -- get the DynFlags
         dyn_flags <- getDynFlags
-       let hsc_lang = hscLang dyn_flags
-       split <- readIORef v_Split_object_files
-
-       let next_phase = case hsc_lang of
-                               HscC -> HCc
-                               HscAsm | split -> SplitMangle
-                                      | otherwise -> As
-                               HscNothing -> HCc
-
-       output_fn <- get_output_fn next_phase
+       hsc_lang <- hscMaybeAdjustLang (hscLang dyn_flags)
+       next_phase <- hscNextPhase hsc_lang
+       output_fn <- get_output_fn next_phase (Just location)
 
-        let dyn_flags' = dyn_flags { hscOutName = output_fn,
+        let dyn_flags' = dyn_flags { hscLang = hsc_lang,
+                                    hscOutName = output_fn,
                                     hscStubCOutName = basename ++ "_stub.c",
                                     hscStubHOutName = basename ++ "_stub.h",
                                     extCoreName = basename ++ ".hcr" }
@@ -629,7 +643,7 @@ runPhase Hsc basename suff input_fn get_output_fn = do
 
             HscNoRecomp pcs details iface -> do
                SysTools.touch "Touching object file" o_file
-               return (Nothing, output_fn)
+               return (Nothing, Just location, output_fn)
 
            HscRecomp _pcs _details _iface stub_h_exists stub_c_exists
                      _maybe_interpreted_code -> do
@@ -640,8 +654,8 @@ runPhase Hsc basename suff input_fn get_output_fn = do
                      Nothing -> return ()
                      Just stub_o -> add v_Ld_inputs stub_o
                case hscLang dyn_flags of
-                      HscNothing -> return (Nothing, output_fn)
-                     _ -> return (Just next_phase, output_fn)
+                      HscNothing -> return (Nothing, Just location, output_fn)
+                     _ -> return (Just next_phase, Just location, output_fn)
 
 -----------------------------------------------------------------------------
 -- Cc phase
@@ -649,7 +663,7 @@ runPhase Hsc basename suff input_fn get_output_fn = do
 -- we don't support preprocessing .c files (with -E) now.  Doing so introduces
 -- way too many hacks, and I can't say I've ever used it anyway.
 
-runPhase cc_phase basename suff input_fn get_output_fn
+runPhase cc_phase basename suff input_fn get_output_fn maybe_loc
    | cc_phase == Cc || cc_phase == HCc
    = do        cc_opts <- getOpts opt_c
                cmdline_include_paths <- readIORef v_Include_paths
@@ -663,7 +677,7 @@ runPhase cc_phase basename suff input_fn get_output_fn
                | hcc && mangle     = Mangle
                | otherwise         = As
 
-       output_fn <- get_output_fn next_phase
+       output_fn <- get_output_fn next_phase maybe_loc
 
        -- HC files have the dependent packages stamped into them
        pkgs <- if hcc then getHCFilePackages input_fn else return []
@@ -717,14 +731,14 @@ runPhase cc_phase basename suff input_fn get_output_fn
                       ++ pkg_extra_cc_opts
                       ))
 
-       return (Just next_phase, output_fn)
+       return (Just next_phase, maybe_loc, output_fn)
 
        -- ToDo: postprocess the output from gcc
 
 -----------------------------------------------------------------------------
 -- Mangle phase
 
-runPhase Mangle _basename _suff input_fn get_output_fn
+runPhase Mangle _basename _suff input_fn get_output_fn maybe_loc
    = do mangler_opts <- getOpts opt_m
         machdep_opts <- if (prefixMatch "i386" cTARGETPLATFORM)
                          then do n_regs <- dynFlag stolen_x86_regs
@@ -735,7 +749,7 @@ runPhase Mangle _basename _suff input_fn get_output_fn
        let next_phase
                | split = SplitMangle
                | otherwise = As
-       output_fn <- get_output_fn next_phase
+       output_fn <- get_output_fn next_phase maybe_loc
 
        SysTools.runMangle (map SysTools.Option mangler_opts
                          ++ [ SysTools.FileOption "" input_fn
@@ -743,12 +757,12 @@ runPhase Mangle _basename _suff input_fn get_output_fn
                             ]
                          ++ map SysTools.Option machdep_opts)
 
-       return (Just next_phase, output_fn)
+       return (Just next_phase, maybe_loc, output_fn)
 
 -----------------------------------------------------------------------------
 -- Splitting phase
 
-runPhase SplitMangle _basename _suff input_fn get_output_fn
+runPhase SplitMangle _basename _suff input_fn get_output_fn maybe_loc
   = do  -- tmp_pfx is the prefix used for the split .s files
        -- We also use it as the file to contain the no. of split .s files (sigh)
        split_s_prefix <- SysTools.newTempName "split"
@@ -768,16 +782,17 @@ runPhase SplitMangle _basename _suff input_fn get_output_fn
        addFilesToClean [ split_s_prefix ++ "__" ++ show n ++ ".s"
                        | n <- [1..n_files]]
 
-       return (Just SplitAs, "**splitmangle**")  -- we don't use the filename
+       return (Just SplitAs, maybe_loc, "**splitmangle**")
+         -- we don't use the filename
 
 -----------------------------------------------------------------------------
 -- As phase
 
-runPhase As _basename _suff input_fn get_output_fn
+runPhase As _basename _suff input_fn get_output_fn maybe_loc
   = do as_opts               <- getOpts opt_a
         cmdline_include_paths <- readIORef v_Include_paths
 
-       output_fn <- get_output_fn Ln
+       output_fn <- get_output_fn Ln maybe_loc
 
        SysTools.runAs (map SysTools.Option as_opts
                       ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ]
@@ -787,10 +802,10 @@ runPhase As _basename _suff input_fn get_output_fn
                          , SysTools.FileOption "" output_fn
                          ])
 
-       return (Just Ln, output_fn)
+       return (Just Ln, maybe_loc, output_fn)
 
 
-runPhase SplitAs basename _suff _input_fn get_output_fn
+runPhase SplitAs basename _suff _input_fn get_output_fn maybe_loc
   = do  as_opts <- getOpts opt_a
 
        (split_s_prefix, n) <- readIORef v_Split_info
@@ -815,14 +830,15 @@ runPhase SplitAs basename _suff _input_fn get_output_fn
        
        mapM_ assemble_file [1..n]
 
-       return (Just Ln, "**split_as**") -- we don't use the output file
+       output_fn <- get_output_fn Ln maybe_loc
+       return (Just Ln, maybe_loc, output_fn)
 
 #ifdef ILX
 -----------------------------------------------------------------------------
 -- Ilx2Il phase
 -- Run ilx2il over the ILX output, getting an IL file
 
-runPhase Ilx2Il _basename _suff input_fn get_output_fn
+runPhase Ilx2Il _basename _suff input_fn get_output_fn maybe_loc
   = do ilx2il_opts <- getOpts opt_I
         SysTools.runIlx2il (map SysTools.Option ilx2il_opts
                            ++ [ SysTools.Option "--no-add-suffix-to-assembly",
@@ -836,7 +852,7 @@ runPhase Ilx2Il _basename _suff input_fn get_output_fn
 -- Ilasm phase
 -- Run ilasm over the IL, getting a DLL
 
-runPhase Ilasm _basename _suff input_fn get_output_fn
+runPhase Ilasm _basename _suff input_fn get_output_fn maybe_loc
   = do ilasm_opts <- getOpts opt_i
         SysTools.runIlasm (map SysTools.Option ilasm_opts
                           ++ [ SysTools.Option "/QUIET",
@@ -1052,8 +1068,8 @@ staticLink o_files dep_packages = do
 -----------------------------------------------------------------------------
 -- Making a DLL (only for Win32)
 
-doMkDLL :: [String] -> IO ()
-doMkDLL o_files = do
+doMkDLL :: [String] -> [PackageName] -> IO ()
+doMkDLL o_files dep_packages = do
     verb       <- getVerbFlag
     static     <- readIORef v_Static
     no_hs_main <- readIORef v_NoHsMain
@@ -1061,13 +1077,13 @@ doMkDLL o_files = do
     o_file <- readIORef v_Output_file
     let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; }
 
-    pkg_lib_paths <- getPackageLibraryPath []
+    pkg_lib_paths <- getPackageLibraryPath dep_packages
     let pkg_lib_path_opts = map ("-L"++) pkg_lib_paths
 
     lib_paths <- readIORef v_Library_paths
     let lib_path_opts = map ("-L"++) lib_paths
 
-    pkg_link_opts <- getPackageLinkOpts []
+    pkg_link_opts <- getPackageLinkOpts dep_packages
 
        -- probably _stub.o files
     extra_ld_inputs <- readIORef v_Ld_inputs
@@ -1102,3 +1118,33 @@ doMkDLL o_files = do
               then [ "" ]
                else [ "--export-all" ])
        ))
+
+-- -----------------------------------------------------------------------------
+-- Misc.
+
+hscNextPhase :: HscLang -> IO Phase
+hscNextPhase hsc_lang = do
+  split <- readIORef v_Split_object_files
+  return (case hsc_lang of
+               HscC -> HCc
+               HscAsm | split -> SplitMangle
+                      | otherwise -> As
+               HscNothing     -> HCc  -- dummy (no output will be generated)
+               HscInterpreted -> HCc  -- "" ""
+               _other         -> HCc  -- "" ""
+       )
+
+hscMaybeAdjustLang :: HscLang -> IO HscLang
+hscMaybeAdjustLang current_hsc_lang = do
+  todo    <- readIORef v_GhcMode
+  keep_hc <- readIORef v_Keep_hc_files
+  let hsc_lang
+       -- don't change the lang if we're interpreting
+        | current_hsc_lang == HscInterpreted = current_hsc_lang
+       -- force -fvia-C if we are being asked for a .hc file
+        | todo == StopBefore HCc  || keep_hc = HscC
+       -- force -fvia-C when profiling or ticky-ticky is on
+        | opt_SccProfilingOn || opt_DoTickyProfiling = HscC
+       -- otherwise, stick to the plan
+        | otherwise = current_hsc_lang
+  return hsc_lang