From 238b58e436a24fcb76846f24b37c90b873ef2bef Mon Sep 17 00:00:00 2001
From: Kari Pahula <kaol@iki.fi>
Date: Fri, 20 Sep 2019 10:11:53 +0300
Subject: Add -fkeep-going to make compiler continue despite errors (#15424)

Add a new optional failure handling for upsweep which continues
the compilation on other modules if any of them has errors.
---
 compiler/main/DynFlags.hs |  2 ++
 compiler/main/GhcMake.hs  | 39 ++++++++++++++++++++++++++++++++++++---
 2 files changed, 38 insertions(+), 3 deletions(-)

(limited to 'compiler/main')

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index c2d0322cd9..5bd8cb819f 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -653,6 +653,7 @@ data GeneralFlag
    -- response file and as such breaking apart.
    | Opt_SingleLibFolder
    | Opt_KeepCAFs
+   | Opt_KeepGoing
 
    -- output style opts
    | Opt_ErrorSpans -- Include full span info in error messages,
@@ -4206,6 +4207,7 @@ fFlagsDeps = [
   flagSpec "ignore-interface-pragmas"         Opt_IgnoreInterfacePragmas,
   flagGhciSpec "implicit-import-qualified"    Opt_ImplicitImportQualified,
   flagSpec "irrefutable-tuples"               Opt_IrrefutableTuples,
+  flagSpec "keep-going"                       Opt_KeepGoing,
   flagSpec "kill-absence"                     Opt_KillAbsence,
   flagSpec "kill-one-shot"                    Opt_KillOneShot,
   flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 81311c1e0c..6e44a86f28 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1357,6 +1357,25 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
  where
   done_holes = emptyUniqSet
 
+  keep_going this_mods old_hpt done mods mod_index nmods uids_to_check done_holes = do
+    let sum_deps ms (AcyclicSCC mod) =
+          if any (flip elem . map (unLoc . snd) $ ms_imps mod) ms
+            then ms_mod_name mod:ms
+            else ms
+        sum_deps ms _ = ms
+        dep_closure = foldl' sum_deps this_mods mods
+        dropped_ms = drop (length this_mods) (reverse dep_closure)
+        prunable (AcyclicSCC mod) = elem (ms_mod_name mod) dep_closure
+        prunable _ = False
+        mods' = filter (not . prunable) mods
+        nmods' = nmods - length dropped_ms
+
+    when (not $ null dropped_ms) $ do
+        dflags <- getSessionDynFlags
+        liftIO $ fatalErrorMsg dflags (keepGoingPruneErr dropped_ms)
+    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods' uids_to_check done_holes
+    return (Failed, done')
+
   upsweep'
     :: GhcMonad m
     => HomePackageTable
@@ -1374,10 +1393,13 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
         return (Succeeded, done)
 
   upsweep' _old_hpt done
-     (CyclicSCC ms:_) _ _ _ _
+     (CyclicSCC ms:mods) mod_index nmods uids_to_check done_holes
    = do dflags <- getSessionDynFlags
         liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms)
-        return (Failed, done)
+        if gopt Opt_KeepGoing dflags
+          then keep_going (map ms_mod_name ms) old_hpt done mods mod_index nmods
+                          uids_to_check done_holes
+          else return (Failed, done)
 
   upsweep' old_hpt done
      (AcyclicSCC mod:mods) mod_index nmods uids_to_check done_holes
@@ -1426,7 +1448,12 @@ upsweep mHscMessage old_hpt stable_mods cleanup sccs = do
                  return (Just mod_info)
 
         case mb_mod_info of
-          Nothing -> return (Failed, done)
+          Nothing -> do
+                dflags <- getSessionDynFlags
+                if gopt Opt_KeepGoing dflags
+                  then keep_going [ms_mod_name mod] old_hpt done mods mod_index nmods
+                                  uids_to_check done_holes
+                  else return (Failed, done)
           Just mod_info -> do
                 let this_mod = ms_mod_name mod
 
@@ -2652,6 +2679,12 @@ multiRootsErr dflags summs@(summ1:_)
     mod = ms_mod summ1
     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
 
+keepGoingPruneErr :: [ModuleName] -> SDoc
+keepGoingPruneErr ms
+  = vcat (( text "-fkeep-going in use, removing the following" <+>
+            text "dependencies and continuing:"):
+          map (nest 6 . ppr) ms )
+
 cyclicModuleErr :: [ModSummary] -> SDoc
 -- From a strongly connected component we find
 -- a single cycle to report
-- 
cgit v1.2.1