X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FDriverPipeline.hs;h=86f94ae8fc7350e00a883ab8bc0f881edb235fc3;hb=880a6b90ba6d93e55a464bea585f9d7c5e4abfb3;hp=6721b9154c2eb15a2030b262f89850cabbf30918;hpb=aa9a4f1053d3c554629a2ec25955e7530c95b892;p=ghc-hetmet.git

diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 6721b91..86f94ae 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -46,10 +46,10 @@ import StringBuffer	( hGetStringBuffer )
 import BasicTypes	( SuccessFlag(..) )
 import Maybes		( expectJust )
 import ParserCoreUtils	( getCoreModuleName )
-import SrcLoc		( unLoc )
-import SrcLoc		( Located(..) )
+import SrcLoc
 import FastString
 
+import Data.Either
 import Exception
 import Data.IORef	( readIORef, writeIORef, IORef )
 import GHC.Exts		( Int(..) )
@@ -296,17 +296,7 @@ link LinkBinary dflags batch_attempt_linking hpt
 
             exe_file = exeFileName dflags
 
-        -- if the modification time on the executable is later than the
-        -- modification times on all of the objects, then omit linking
-        -- (unless the -fforce-recomp flag was given).
-        e_exe_time <- IO.try $ getModificationTime exe_file
-        extra_ld_inputs <- readIORef v_Ld_inputs
-        extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs
-        let other_times = map linkableTime linkables
-                       ++ [ t' | Right t' <- extra_times ]
-            linking_needed = case e_exe_time of
-                               Left _  -> True
-                               Right t -> any (t <) other_times
+        linking_needed <- linkingNeeded dflags linkables pkg_deps
 
         if not (dopt Opt_ForceRecomp dflags) && not linking_needed
            then do debugTraceMsg dflags 2 (text exe_file <+> ptext (sLit "is up to date, linking not required."))
@@ -339,6 +329,51 @@ link other _ _ _ = panicBadLink other
 panicBadLink :: GhcLink -> a
 panicBadLink other = panic ("link: GHC not built to link this way: " ++
                             show other)
+
+
+linkingNeeded :: DynFlags -> [Linkable] -> [PackageId] -> IO Bool
+linkingNeeded dflags linkables pkg_deps = do
+        -- if the modification time on the executable is later than the
+        -- modification times on all of the objects and libraries, then omit
+        -- linking (unless the -fforce-recomp flag was given).
+  let exe_file = exeFileName dflags
+  e_exe_time <- IO.try $ getModificationTime exe_file
+  case e_exe_time of
+    Left _  -> return True
+    Right t -> do
+        -- first check object files and extra_ld_inputs
+        extra_ld_inputs <- readIORef v_Ld_inputs
+        e_extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs
+        let (errs,extra_times) = splitEithers e_extra_times
+        let obj_times =  map linkableTime linkables ++ extra_times
+        if not (null errs) || any (t <) obj_times
+            then return True 
+            else do
+
+        -- next, check libraries. XXX this only checks Haskell libraries,
+        -- not extra_libraries or -l things from the command line.
+        let pkg_map = pkgIdMap (pkgState dflags)
+            pkg_hslibs  = [ (libraryDirs c, lib)
+                          | Just c <- map (lookupPackage pkg_map) pkg_deps,
+                            lib <- packageHsLibs dflags c ]
+
+        pkg_libfiles <- mapM (uncurry findHSLib) pkg_hslibs
+        if any isNothing pkg_libfiles then return True else do
+        e_lib_times <- mapM (IO.try . getModificationTime)
+                          (catMaybes pkg_libfiles)
+        let (lib_errs,lib_times) = splitEithers e_lib_times
+        if not (null lib_errs) || any (t <) lib_times
+           then return True
+           else return False
+
+findHSLib :: [String] -> String -> IO (Maybe FilePath)
+findHSLib dirs lib = do
+  let batch_lib_file = "lib" ++ lib <.> "a"
+  found <- filterM doesFileExist (map (</> batch_lib_file) dirs)
+  case found of
+    [] -> return Nothing
+    (x:_) -> return (Just x)
+
 -- -----------------------------------------------------------------------------
 -- Compile files in one-shot mode.
 
@@ -616,12 +651,12 @@ runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_l
 -- Cpp phase : (a) gets OPTIONS out of file
 --	       (b) runs cpp if necessary
 
-runPhase (Cpp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc
+runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
   = do let dflags0 = hsc_dflags hsc_env
        src_opts <- getOptionsFromFile dflags0 input_fn
-       (dflags, unhandled_flags, warns) <- parseDynamicFlags dflags0 (map unLoc src_opts)
+       (dflags, unhandled_flags, warns) <- parseDynamicFlags dflags0 src_opts
        handleFlagWarnings dflags warns
-       checkProcessArgsResult unhandled_flags (basename <.> suff)
+       checkProcessArgsResult unhandled_flags
 
        if not (dopt Opt_Cpp dflags) then
            -- no need to preprocess CPP, just pass input file along
@@ -852,7 +887,13 @@ runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc
 
         let verb = getVerbFlag dflags
 
-	pkg_extra_cc_opts <- getPackageExtraCcOpts dflags pkgs
+        -- cc-options are not passed when compiling .hc files.  Our
+        -- hc code doesn't not #include any header files anyway, so these
+        -- options aren't necessary.
+	pkg_extra_cc_opts <-
+          if cc_phase `eqPhase` HCc
+             then return []
+             else getPackageExtraCcOpts dflags pkgs
 
 #ifdef darwin_TARGET_OS
         pkg_framework_paths <- getPackageFrameworkPath dflags pkgs
@@ -1120,7 +1161,7 @@ runPhase_MoveBinary dflags input_fn dep_packages
            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?
-        Panic.try (removeFile pvm_executable)
+        tryIO (removeFile pvm_executable)
         -- move the newly created binary into PVM land
         copy dflags "copying PVM executable" input_fn pvm_executable
         -- generate a wrapper script for running a parallel prg under PVM