Ticket #4900: alternative.patch

compiler/main/DriverPipeline.hs

@@ -210 +210 @@
                               return [DotO stub_o]
 
                 let hs_unlinked = [BCOs comp_bc modBreaks]
-                    unlinked_time = ms_hs_date summary
+
+                    usage_file_mtimes = map snd (ms_usage_files summary)
+                    unlinked_time =
+                        maximum (ms_hs_date summary : catMaybes usage_file_mtimes)
                   -- Why do we use the timestamp of the source file here,
                   -- rather than the current time?  This works better in
                   -- the case where the local clock is out of sync
                   -- with the filesystem's clock.  It's just as accurate:
                   -- if the source is modified, then the linkable will
                   -- be out of date.
+                  -- However, make sure to consider the mtimes of the module's
+                  -- usage files, too.
+
                 let linkable = LM unlinked_time this_mod
                                (hs_unlinked ++ stub_o)
                 return (Just linkable)
@@ -946 +952 @@
                                         ms_hspp_buf  = hspp_buf,
                                         ms_location  = location4,
                                         ms_hs_date   = src_timestamp,
+                                        ms_usage_files = [],
                                         ms_obj_date  = Nothing,
                                         ms_textual_imps = imps,
                                         ms_srcimps      = src_imps }

compiler/main/GHC.hs

@@ -882 +882 @@
          -- want. (Thus it doesn't matter what the timestamp
          -- for the (nonexistent) source file is.)
          ms_hs_date = currentTime,
+         ms_usage_files = [],
          ms_obj_date = Nothing,
          -- Only handling the single-module case for now, so no imports.
          ms_srcimps = [],

compiler/main/GhcMake.hs

@@ -253 +253 @@
                                2 (ppr mg))
 
     setSession hsc_env{ hsc_HPT = emptyHomePackageTable }
-    (upsweep_ok, modsUpswept)
+    (upsweep_ok, modsUpswept, modsNotUpswept)
        <- upsweep pruned_hpt stable_mods cleanup mg
 
     -- Make modsDone be the summaries for each home module now
@@ -262 +262 @@
 
     let modsDone = reverse modsUpswept
 
+    -- The upswept modules were possibly changed, so update the module graph.
+    modifySession $ \hsc_env -> hsc_env
+        { hsc_mod_graph = modsUpswept ++ modsNotUpswept }
+
     -- Try and do linking in some form, depending on whether the
     -- upsweep was completely or only partially successful.
 
@@ -502 +506 @@
         all stableObject (imports m)
         && old linkable does not exist, or is == on-disk .o
         && date(on-disk .o) > date(.hs)
+        && date(linkableTime) > usage file dates
 
   stableBCO m =
         all stable (imports m)
         && date(BCO) > date(.hs)
+        && date(linkableTime) > usage file dates
 @
 
   These properties embody the following ideas:
@@ -567 +573 @@
           where
              same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of
                                 Just hmi  | Just l <- hm_linkable hmi
-                                 -> isObjectLinkable l && t == linkableTime l
+                                 -> isObjectLinkable l && t == linkableTime l &&
+                                    usage_files_ok ms l
                                 _other  -> True
                 -- why '>=' rather than '>' above?  If the filesystem stores
                 -- times to the nearset second, we may occasionally find that
@@ -584 +591 @@
           | otherwise = case lookupUFM hpt (ms_mod_name ms) of
                 Just hmi  | Just l <- hm_linkable hmi ->
                         not (isObjectLinkable l) && 
-                        linkableTime l >= ms_hs_date ms
+                        linkableTime l >= ms_hs_date ms &&
+                        usage_files_ok ms l
                 _other  -> False
 
+        -- Check whether the usage files' mtimes are <= the linkableTime.
+        -- An mtime of Nothing means a usage file has been deleted; in that case
+        -- the module is marked unstable.
+        usage_files_ok ms linkable = all (maybe False (<= linkableTime linkable))
+                                         (map snd (ms_usage_files ms))
+
 -- -----------------------------------------------------------------------------
 --
 -- | The upsweep
@@ -602 +616 @@
     -> (HscEnv -> IO ())           -- ^ How to clean up unwanted tmp files
     -> [SCC ModSummary]            -- ^ Mods to do (the worklist)
     -> m (SuccessFlag,
+          [ModSummary],
           [ModSummary])
        -- ^ Returns:
        --
        --  1. A flag whether the complete upsweep was successful.
        --  2. The 'HscEnv' in the monad has an updated HPT
        --  3. A list of modules which succeeded loading.
+       --  4. A list of modules which weren't loaded.
 
 upsweep old_hpt stable_mods cleanup sccs = do
-   (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs)
-   return (res, reverse done)
+   (res, done, notDone) <- upsweep' old_hpt [] sccs 1 (length sccs)
+   return (res, reverse done, flattenSCCs notDone)
  where
 
   upsweep' _old_hpt done
      [] _ _
-   = return (Succeeded, done)
+   = return (Succeeded, done, [])
 
   upsweep' _old_hpt done
-     (CyclicSCC ms:_) _ _
+     mg@(CyclicSCC ms:_) _ _
    = do dflags <- getSessionDynFlags
         liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
-        return (Failed, done)
+        return (Failed, done, mg)
 
   upsweep' old_hpt done
-     (AcyclicSCC mod:mods) mod_index nmods
+     mg@(AcyclicSCC mod:mods) mod_index nmods
    = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ 
         --           show (map (moduleUserString.moduleName.mi_module.hm_iface) 
         --                     (moduleEnvElts (hsc_HPT hsc_env)))
@@ -645 +661 @@
                  return (Just mod_info)
 
         case mb_mod_info of
-          Nothing -> return (Failed, done)
+          Nothing -> return (Failed, done, mg)
           Just mod_info -> do
                 let this_mod = ms_mod_name mod
 
@@ -663 +679 @@
                     old_hpt1 | isBootSummary mod = old_hpt
                              | otherwise = delFromUFM old_hpt this_mod
 
-                    done' = mod:done
+                -- Update the usage files of this mod with data from the
+                -- newly generated HMI
+                let usages      = mi_usages (hm_iface mod_info)
+                    usage_files = [(file,Just mtime) | UsageFile file mtime <- usages]
+
+                    mod'  = mod { ms_usage_files = usage_files }
+                    done' = mod':done
 
                         -- fixup our HomePackageTable after we've finished compiling
                         -- a mutually-recursive loop.  See reTypecheckLoop, below.
-                hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done'
+                hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod' done'
                 setSession hsc_env2
 
                 upsweep' old_hpt1 done' mods (mod_index+1) nmods
@@ -1194 +1216 @@
    = do
         let location = ms_location old_summary
 
+        (usage_files_ok,usage_files) <- checkUsageFiles old_summary
         src_timestamp <- get_src_timestamp
                 -- The file exists; we checked in getRootSummary above.
                 -- If it gets removed subsequently, then this 
@@ -1201 +1224 @@
                 -- behaviour.
 
                 -- return the cached summary if the source didn't change
-        if ms_hs_date old_summary == src_timestamp
+        summary <- if ms_hs_date old_summary == src_timestamp && usage_files_ok
            then do -- update the object-file timestamp
                   obj_timestamp <-
                     if isObjectTarget (hscTarget (hsc_dflags hsc_env)) 
@@ -1212 +1235 @@
            else
                 new_summary src_timestamp
 
+        -- Update the usage file mtimes if a usage file has been altered.
+        return $ if usage_files_ok
+                    then summary
+                    else summary { ms_usage_files = usage_files }
+
    | otherwise
    = do src_timestamp <- get_src_timestamp
         new_summary src_timestamp
@@ -1251 +1279 @@
                              ms_hspp_buf  = Just buf,
                              ms_srcimps = srcimps, ms_textual_imps = the_imps,
                              ms_hs_date = src_timestamp,
+                             ms_usage_files = [],
                              ms_obj_date = obj_timestamp })
 
 findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary
@@ -1282 +1311 @@
         let location = ms_location old_summary
             src_fn = expectJust "summariseModule" (ml_hs_file location)
 
+        (usage_files_ok,usage_files) <- checkUsageFiles old_summary
+
                 -- check the modification time on the source file, and
                 -- return the cached summary if it hasn't changed.  If the
                 -- file has disappeared, we need to call the Finder again.
-        case maybe_buf of
-           Just (_,t) -> check_timestamp old_summary location src_fn t
+        maybe_ms <- case maybe_buf of
+           Just (_,t) -> check_timestamp old_summary location src_fn t usage_files_ok
            Nothing    -> do
                 m <- tryIO (getModificationUTCTime src_fn)
                 case m of
-                   Right t -> check_timestamp old_summary location src_fn t
+                   Right t ->
+                        check_timestamp old_summary location src_fn t usage_files_ok
                    Left e | isDoesNotExistError e -> find_it
                           | otherwise             -> ioError e
 
+        -- Update the usage file mtimes if a usage file has been altered.
+        return $ case maybe_ms of
+            Nothing -> Nothing
+            Just ms | usage_files_ok -> Just ms
+                    | otherwise      -> Just ms { ms_usage_files = usage_files }
+
   | otherwise  = find_it
   where
     dflags = hsc_dflags hsc_env
 
     hsc_src = if is_boot then HsBootFile else HsSrcFile
 
-    check_timestamp old_summary location src_fn src_timestamp
-        | ms_hs_date old_summary == src_timestamp = do
+    check_timestamp old_summary location src_fn src_timestamp usage_files_ok
+        | ms_hs_date old_summary == src_timestamp, usage_files_ok = do
                 -- update the object-file timestamp
                 obj_timestamp <- 
                     if isObjectTarget (hscTarget (hsc_dflags hsc_env))
@@ -1377 +1415 @@
                               ms_srcimps      = srcimps,
                               ms_textual_imps = the_imps,
                               ms_hs_date   = src_timestamp,
+                              ms_usage_files   = [],
                               ms_obj_date  = obj_timestamp }))
 
 
+checkUsageFiles :: ModSummary
+                -> IO (Bool, [(FilePath,Maybe UTCTime)])
+                -- ^ returns whether any usage file has been altered,
+                -- and the entire list of usage files with their mtimes updated
+checkUsageFiles summary = do
+    let (usage_files,old_mtimes) = unzip (ms_usage_files summary)
+    mtimes <- mapM modificationTimeIfExists usage_files
+
+    return (mtimes == old_mtimes, zip usage_files mtimes)
+
 getObjTimestamp :: ModLocation -> Bool -> IO (Maybe UTCTime)
 getObjTimestamp location is_boot
   = if is_boot then return Nothing

compiler/main/HscTypes.lhs

@@ -1813 +1813 @@
         ms_hsc_src      :: HscSource,           -- ^ The module source either plain Haskell, hs-boot or external core
         ms_location     :: ModLocation,         -- ^ Location of the various files belonging to the module
         ms_hs_date      :: UTCTime,             -- ^ Timestamp of source file
+        ms_usage_files  :: [(FilePath,Maybe UTCTime)], -- ^ Usage files and their mtimes
         ms_obj_date     :: Maybe UTCTime,       -- ^ Timestamp of object, if we have one
         ms_srcimps      :: [Located (ImportDecl RdrName)],      -- ^ Source imports of the module
         ms_textual_imps :: [Located (ImportDecl RdrName)],      -- ^ Non-source imports of the module from the module *text*
@@ -1865 +1866 @@
    ppr ms
       = sep [text "ModSummary {",
              nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)),
+                          text "ms_usage_files = " <> text (show (ms_usage_files ms)),
                           text "ms_mod =" <+> ppr (ms_mod ms)
                                 <> text (hscSourceString (ms_hsc_src ms)) <> comma,
                           text "ms_textual_imps =" <+> ppr (ms_textual_imps ms),