Driver rework pt3: the upsweep

This patch specifies and simplifies the module cycle compilation
in upsweep. How things work are described in the Note [Upsweep]

Note [Upsweep]
~~~~~~~~~~~~~~

Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes
the plan in order to compile the project.

The first step is computing the build plan from a 'ModuleGraph'.

The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for
how to build all the modules.

```
data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle
               | ResolvedCycle [ModuleGraphNode]   -- A resolved cycle, linearised by hs-boot files
               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files
```

The plan is computed in two steps:

Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains
        cycles.
Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should
        result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.

The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.

* `SingleModule nodes` are compiled normally by either the upsweep_inst or upsweep_mod functions.
* `ResolvedCycles` need to compiled "together" so that the information which ends up in
  the interface files at the end is accurate (and doesn't contain temporary information from
  the hs-boot files.)
  - During the initial compilation, a `KnotVars` is created which stores an IORef TypeEnv for
    each module of the loop. These IORefs are gradually updated as the loop completes and provide
    the required laziness to typecheck the module loop.
  - At the end of typechecking, all the interface files are typechecked again in
    the retypecheck loop. This time, the knot-tying is done by the normal laziness
    based tying, so the environment is run without the KnotVars.
* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files
  and are reported as an error to the user.

The main trickiness of `interpretBuildPlan` is deciding which version of a dependency
is visible from each module. For modules which are not in a cycle, there is just
one version of a module, so that is always used. For modules in a cycle, there are two versions of
'HomeModInfo'.

1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.
2. External to loop: The knot-tied version created by typecheckLoop.

Whilst compiling a module inside the loop, we need to use the (1). For a module which
is outside of the loop which depends on something from in the loop, the (2) version
is used.

As the plan is interpreted, which version of a HomeModInfo is visible is updated
by updating a map held in a state monad. So after a loop has finished being compiled,
the visible module is the one created by typecheckLoop and the internal version is not
used again.

This plan also ensures the most important invariant to do with module loops:

> If you depend on anything within a module loop, before you can use the dependency,
  the whole loop has to finish compiling.

The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs
of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running
the action. This list is topologically sorted, so can be run in order to compute
the whole graph.

As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which
can be queried at the end to get the result of all modules at the end, with their proper
visibility. For example, if any module in a loop fails then all modules in that loop will
report as failed because the visible node at the end will be the result of retypechecking
those modules together.

Along the way we also fix a number of other bugs in the driver:

* Unify upsweep and parUpsweep.
* Fix #19937 (static points, ghci and -j)
* Adds lots of module loop tests due to Divam.

Also related to #20030

Co-authored-by: Divam Narula <dfordivam@gmail.com>

-------------------------
Metric Decrease:
    T10370
-------------------------

22 files changed, 1050 insertions, 1071 deletions

diff --git a/compiler/GHC/Core/TyCo/Rep.hs-boot b/compiler/GHC/Core/TyCo/Rep.hs-boot
index 614a596bbe..0c89a2f077 100644
--- a/compiler/GHC/Core/TyCo/Rep.hs-boot
+++ b/compiler/GHC/Core/TyCo/Rep.hs-boot
@@ -1,3 +1,4 @@
+{-# LANGUAGE NoPolyKinds #-}
 module GHC.Core.TyCo.Rep where
 
 import GHC.Utils.Outputable ( Outputable )
diff --git a/compiler/GHC/Data/Graph/Directed.hs b/compiler/GHC/Data/Graph/Directed.hs
index c773898596..62482bfe30 100644
--- a/compiler/GHC/Data/Graph/Directed.hs
+++ b/compiler/GHC/Data/Graph/Directed.hs
@@ -12,7 +12,7 @@ module GHC.Data.Graph.Directed (
         stronglyConnCompG,
         topologicalSortG,
         verticesG, edgesG, hasVertexG,
-        reachableG, reachablesG, transposeG,
+        reachableG, reachablesG, transposeG, allReachable, outgoingG,
         emptyG,
 
         findCycle,
@@ -25,7 +25,7 @@ module GHC.Data.Graph.Directed (
 
         -- Simple way to classify edges
         EdgeType(..), classifyEdges
-    ) where
+        ) where
 
 ------------------------------------------------------------------------------
 -- A version of the graph algorithms described in:
@@ -61,6 +61,9 @@ import Data.Graph hiding (Graph, Edge, transposeG, reachable)
 import Data.Tree
 import GHC.Types.Unique
 import GHC.Types.Unique.FM
+import qualified Data.IntMap as IM
+import qualified Data.IntSet as IS
+import qualified Data.Map as M
 
 {-
 ************************************************************************
@@ -359,6 +362,11 @@ reachableG graph from = map (gr_vertex_to_node graph) result
   where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
         result = {-# SCC "Digraph.reachable" #-} reachable (gr_int_graph graph) [from_vertex]
 
+outgoingG :: Graph node -> node -> [node]
+outgoingG graph from = map (gr_vertex_to_node graph) result
+  where from_vertex = expectJust "reachableG" (gr_node_to_vertex graph from)
+        result = gr_int_graph graph ! from_vertex
+
 -- | Given a list of roots return all reachable nodes.
 reachablesG :: Graph node -> [node] -> [node]
 reachablesG graph froms = map (gr_vertex_to_node graph) result
@@ -366,6 +374,11 @@ reachablesG graph froms = map (gr_vertex_to_node graph) result
                  reachable (gr_int_graph graph) vs
         vs = [ v | Just v <- map (gr_node_to_vertex graph) froms ]
 
+allReachable :: Ord key => Graph node -> (node -> key) -> M.Map key [key]
+allReachable (Graph g from _) conv =  M.fromList [(conv (from v), IS.foldr (\k vs -> conv (from k) : vs) [] vs) | (v, vs) <- IM.toList int_graph]
+  where
+    int_graph = reachableGraph g
+
 hasVertexG :: Graph node -> node -> Bool
 hasVertexG graph node = isJust $ gr_node_to_vertex graph node
 
@@ -435,6 +448,12 @@ preorderF ts         = concatMap flatten ts
 reachable    :: IntGraph -> [Vertex] -> [Vertex]
 reachable g vs = preorderF (dfs g vs)
 
+reachableGraph :: IntGraph -> IM.IntMap IS.IntSet
+reachableGraph g = res
+  where
+    do_one v = IS.unions (IS.fromList (g ! v) : mapMaybe (flip IM.lookup res) (g ! v))
+    res = IM.fromList [(v, do_one v) | v <- vertices g]
+
 {-
 ************************************************************************
 *                                                                      *
diff --git a/compiler/GHC/Driver/Backpack.hs b/compiler/GHC/Driver/Backpack.hs
index 8e7bbf49d5..a192de853c 100644
--- a/compiler/GHC/Driver/Backpack.hs
+++ b/compiler/GHC/Driver/Backpack.hs
@@ -734,9 +734,17 @@ hsunitModuleGraph unit = do
             -- Using extendModSummaryNoDeps here is okay because we're making a leaf node
             -- representing a signature that can't depend on any other unit.
 
+    let graph_nodes = (ModuleNode <$> (nodes ++ req_nodes)) ++ (instantiationNodes (hsc_units hsc_env))
+        key_nodes = map mkNodeKey graph_nodes
+    -- This error message is not very good but .bkp mode is just for testing so
+    -- better to be direct rather than pretty.
+    when
+      (length key_nodes /= length (ordNub key_nodes))
+      (pprPanic "Duplicate nodes keys in backpack file" (ppr key_nodes))
+
     -- 3. Return the kaboodle
-    return $ mkModuleGraph' $
-      (ModuleNode <$> (nodes ++ req_nodes)) ++ instantiationNodes (hsc_units hsc_env)
+    return $ mkModuleGraph' $ graph_nodes
+
 
 summariseRequirement :: PackageName -> ModuleName -> BkpM ModSummary
 summariseRequirement pn mod_name = do
@@ -849,8 +857,6 @@ hsModuleToModSummary pn hsc_src modname
                         HsBootFile -> addBootSuffixLocnOut location0
                         _ -> location0
     -- This duplicates a pile of logic in GHC.Driver.Make
-    env <- getBkpEnv
-    src_hash <- liftIO $ getFileHash (bkp_filename env)
     hi_timestamp <- liftIO $ modificationTimeIfExists (ml_hi_file location)
     hie_timestamp <- liftIO $ modificationTimeIfExists (ml_hie_file location)
 
@@ -901,7 +907,10 @@ hsModuleToModSummary pn hsc_src modname
                     hpm_module = hsmod,
                     hpm_src_files = [] -- TODO if we preprocessed it
                 }),
-            ms_hs_hash = src_hash,
+            -- Source hash = fingerprint0, so the recompilation tests do not recompile
+            -- too much. In future, if necessary then could get the hash by just hashing the
+            -- relevant part of the .bkp file.
+            ms_hs_hash = fingerprint0,
             ms_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
             ms_dyn_obj_date = Nothing, -- TODO do this, but problem: hi_timestamp is BOGUS
             ms_iface_date = hi_timestamp,
diff --git a/compiler/GHC/Driver/Env/KnotVars.hs b/compiler/GHC/Driver/Env/KnotVars.hs
new file mode 100644
index 0000000000..73f348835f
--- /dev/null
+++ b/compiler/GHC/Driver/Env/KnotVars.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE DeriveFunctor #-}
+-- | This data structure holds an updateable environment which is used
+-- when compiling module loops.
+module GHC.Driver.Env.KnotVars( KnotVars(..)
+                              , emptyKnotVars
+                              , knotVarsFromModuleEnv
+                              , knotVarElems
+                              , lookupKnotVars
+                              , knotVarsWithout
+                              ) where
+
+import GHC.Prelude
+import GHC.Unit.Types ( Module )
+import GHC.Unit.Module.Env
+import Data.Maybe
+
+-- See Note [Why is KnotVars not a ModuleEnv]
+data KnotVars a = KnotVars { kv_domain :: [Module] -- Domain of the function , Note [KnotVars: Why store the domain?]
+                           -- Invariant: kv_lookup is surjective relative to kv_domain
+                           , kv_lookup :: Module -> Maybe a -- Lookup function
+                           }
+                           deriving Functor
+
+emptyKnotVars :: KnotVars a
+emptyKnotVars = KnotVars [] (const Nothing)
+
+knotVarsFromModuleEnv :: ModuleEnv a -> KnotVars a
+knotVarsFromModuleEnv me = KnotVars (moduleEnvKeys me) (lookupModuleEnv me)
+
+knotVarElems :: KnotVars a -> [a]
+knotVarElems (KnotVars keys lookup) = mapMaybe lookup keys
+
+lookupKnotVars :: KnotVars a -> Module -> Maybe a
+lookupKnotVars (KnotVars _ lookup) = lookup
+
+knotVarsWithout :: Module -> KnotVars a -> KnotVars a
+knotVarsWithout this_mod (KnotVars loop_mods lkup) = KnotVars
+  (filter (/= this_mod) loop_mods)
+  (\that_mod -> if that_mod == this_mod then Nothing else lkup that_mod)
+
+{-
+Note [Why is KnotVars not a ModuleEnv]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Initially 'KnotVars' was just a 'ModuleEnv a' but there is one tricky use of
+the data structure in 'mkDsEnvs' which required this generalised structure.
+
+In interactive mode the TypeEnvs from all the previous statements are merged
+togethed into one big TypeEnv. 'dsLookupVar' relies on `tcIfaceVar'. The normal
+lookup functions either look in the HPT or EPS but there is no entry for the `Ghci<N>` modules
+in either, so the whole merged TypeEnv for all previous Ghci* is stored in the
+`if_rec_types` variable and then lookup checks there in the case of any interactive module.
+
+This is a misuse of the `if_rec_types` variable which might be fixed in future if the
+Ghci<N> modules are just placed into the HPT like normal modules with implicit imports
+between them.
+
+Note [KnotVars: Why store the domain?]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Normally there's a 'Module' at hand to tell us which 'TypeEnv' we want to interrogate
+at a particular time, apart from one case, when constructing the in-scope set
+when linting an unfolding. In this case the whole environemnt is needed to tell us
+everything that's in-scope at top-level in the loop because whilst we are linting unfoldings
+the top-level identifiers from modules in the cycle might not be globalised properly yet.
+
+This could be refactored so that the lint functions knew about 'KnotVars' and delayed
+this check until deciding whether a variable was local or not.
+
+-}
+
diff --git a/compiler/GHC/Driver/Env/Types.hs b/compiler/GHC/Driver/Env/Types.hs
index 7301ae70b3..0c58ac8855 100644
--- a/compiler/GHC/Driver/Env/Types.hs
+++ b/compiler/GHC/Driver/Env/Types.hs
@@ -18,7 +18,6 @@ import GHC.Types.TypeEnv
 import GHC.Unit.Finder.Types
 import GHC.Unit.Module.Graph
 import GHC.Unit.Env
-import GHC.Unit.Types
 import GHC.Utils.Logger
 import GHC.Utils.TmpFs
 import {-# SOURCE #-} GHC.Driver.Plugins
@@ -27,6 +26,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
 import Control.Monad.Trans.State
 import Data.IORef
+import GHC.Driver.Env.KnotVars
 
 -- | The Hsc monad: Passing an environment and diagnostic state
 newtype Hsc a = Hsc (HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
@@ -76,7 +76,7 @@ data HscEnv
         hsc_FC   :: {-# UNPACK #-} !FinderCache,
                 -- ^ The cached result of performing finding in the file system
 
-        hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
+        hsc_type_env_vars :: KnotVars (IORef TypeEnv)
                 -- ^ Used for one-shot compilation only, to initialise
                 -- the 'IfGblEnv'. See 'GHC.Tc.Utils.tcg_type_env_var' for
                 -- 'GHC.Tc.Utils.TcGblEnv'.  See also Note [hsc_type_env_var hack]
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 24552da8c1..d041d918bb 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -235,6 +235,7 @@ import Data.Functor
 import Control.DeepSeq (force)
 import Data.Bifunctor (first)
 import GHC.Data.Maybe
+import GHC.Driver.Env.KnotVars
 
 {- **********************************************************************
 %*                                                                      *
@@ -256,7 +257,7 @@ newHscEnv dflags = do
                   ,  hsc_IC             = emptyInteractiveContext dflags
                   ,  hsc_NC             = nc_var
                   ,  hsc_FC             = fc_var
-                  ,  hsc_type_env_var   = Nothing
+                  ,  hsc_type_env_vars  = emptyKnotVars
                   ,  hsc_interp         = Nothing
                   ,  hsc_unit_env       = unit_env
                   ,  hsc_plugins        = []
@@ -1039,12 +1040,28 @@ hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
 -- NoRecomp handlers
 --------------------------------------------------------------
 
--- NB: this must be knot-tied appropriately, see hscIncrementalCompile
+
+-- | genModDetails is used to initialise 'ModDetails' at the end of compilation.
+-- This has two main effects:
+-- 1. Increases memory usage by unloading a lot of the TypeEnv
+-- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos)
+-- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than
+-- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups
+-- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns.
+
+-- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new
+-- more compact and more correct version. This reduces memory usage whilst compiling the rest of
+-- the module loop.
 genModDetails :: HscEnv -> ModIface -> IO ModDetails
 genModDetails hsc_env old_iface
   = do
+    -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and
+    -- hence properly globalises DFunIds.
     new_details <- {-# SCC "tcRnIface" #-}
-                   initIfaceLoad hsc_env (typecheckIface old_iface)
+                  initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface)
+    case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of
+      Nothing -> return ()
+      Just te_var -> writeIORef te_var (md_types new_details)
     dumpIfaceStats hsc_env
     return new_details
 
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index d40be12308..736d5771f5 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -8,6 +8,14 @@
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
 {-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralisedNewtypeDeriving #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE ApplicativeDo #-}
 
 -- -----------------------------------------------------------------------------
 --
@@ -36,16 +44,16 @@ module GHC.Driver.Make (
 
         noModError, cyclicModuleErr,
         moduleGraphNodes, SummaryNode,
-        IsBootInterface(..),
+        IsBootInterface(..), mkNodeKey,
 
         ModNodeMap(..), emptyModNodeMap, modNodeMapElems, modNodeMapLookup, modNodeMapInsert
-    ) where
+        ) where
 
 import GHC.Prelude
 import GHC.Platform
 
 import GHC.Tc.Utils.Backpack
-import GHC.Tc.Utils.Monad  ( initIfaceCheck )
+import GHC.Tc.Utils.Monad  ( initIfaceLoad )
 
 import GHC.Runtime.Interpreter
 import qualified GHC.Linker.Loader as Linker
@@ -54,7 +62,6 @@ import GHC.Linker.Types
 import GHC.Runtime.Context
 
 import GHC.Driver.Config.Finder (initFinderOpts)
-import GHC.Driver.Config.Logger (initLogFlags)
 import GHC.Driver.Config.Parser (initParserOpts)
 import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Phases
@@ -81,7 +88,6 @@ import GHC.Data.StringBuffer
 import qualified GHC.LanguageExtensions as LangExt
 
 import GHC.Utils.Exception ( AsyncException(..), evaluate )
-import GHC.Utils.Monad     ( allM, MonadIO )
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
@@ -113,23 +119,18 @@ import GHC.Unit.Home.ModInfo
 
 import Data.Either ( rights, partitionEithers )
 import qualified Data.Map as Map
-import Data.Map (Map)
 import qualified Data.Set as Set
 import qualified GHC.Data.FiniteMap as Map ( insertListWith )
 
-import Control.Concurrent ( forkIOWithUnmask, killThread )
+import Control.Concurrent ( forkIO, newQSem, waitQSem, signalQSem )
 import qualified GHC.Conc as CC
 import Control.Concurrent.MVar
-import Control.Concurrent.QSem
 import Control.Monad
 import Control.Monad.Trans.Except ( ExceptT(..), runExceptT, throwE )
 import qualified Control.Monad.Catch as MC
 import Data.IORef
-import Data.List (sortBy, partition)
-import qualified Data.List as List
 import Data.Foldable (toList)
 import Data.Maybe
-import Data.Ord ( comparing )
 import Data.Time
 import Data.Bifunctor (first)
 import System.Directory
@@ -137,11 +138,17 @@ import System.FilePath
 import System.IO        ( fixIO )
 
 import GHC.Conc ( getNumProcessors, getNumCapabilities, setNumCapabilities )
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Reader
+import GHC.Driver.Pipeline.LogQueue
+import qualified Data.Map.Strict as M
+import GHC.Types.TypeEnv
+import Control.Monad.Trans.State.Lazy
+import Control.Monad.Trans.Class
+import GHC.Driver.Env.KnotVars
+import Control.Concurrent.STM
+import Control.Monad.Trans.Maybe
 
-label_self :: String -> IO ()
-label_self thread_name = do
-    self_tid <- CC.myThreadId
-    CC.labelThread self_tid thread_name
 
 -- -----------------------------------------------------------------------------
 -- Loading the program
@@ -229,7 +236,8 @@ depanalPartial excluded_mods allow_dup_roots = do
     let
       (errs, mod_summaries) = partitionEithers mod_summariesE
       mod_graph = mkModuleGraph' $
-        fmap ModuleNode mod_summaries ++ instantiationNodes (hsc_units hsc_env)
+        (instantiationNodes (hsc_units hsc_env))
+        ++ fmap ModuleNode mod_summaries
     return (unionManyMessages errs, mod_graph)
 
 -- | Collect the instantiations of dependencies to create 'InstantiationNode' work graph nodes.
@@ -398,6 +406,78 @@ warnUnusedPackages mod_graph = do
           . Definite
           . unitId
 
+
+data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle
+               | ResolvedCycle [ModuleGraphNode]   -- A resolved cycle, linearised by hs-boot files
+               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files
+
+instance Outputable BuildPlan where
+  ppr (SingleModule mgn) = text "SingleModule" <> parens (ppr mgn)
+  ppr (ResolvedCycle mgn)   = text "ResolvedCycle:" <+> ppr mgn
+  ppr (UnresolvedCycle mgn) = text "UnresolvedCycle:" <+> ppr mgn
+
+
+-- Just used for an assertion
+countMods :: BuildPlan -> Int
+countMods (SingleModule _) = 1
+countMods (ResolvedCycle ns) = length ns
+countMods (UnresolvedCycle ns) = length ns
+
+-- See Note [Upsweep] for a high-level description.
+createBuildPlan :: ModuleGraph -> Maybe ModuleName -> [BuildPlan]
+createBuildPlan mod_graph maybe_top_mod =
+    let -- Step 1: Compute SCCs without .hi-boot files, to find the cycles
+        cycle_mod_graph = topSortModuleGraph True mod_graph maybe_top_mod
+
+        -- Step 2: Reanalyse loops, with relevant boot modules, to solve the cycles.
+        build_plan :: [BuildPlan]
+        build_plan
+          -- Fast path, if there are no boot modules just do a normal toposort
+          | isEmptyModuleEnv boot_modules = collapseAcyclic $ topSortModuleGraph False mod_graph maybe_top_mod
+          | otherwise = toBuildPlan cycle_mod_graph []
+
+        toBuildPlan :: [SCC ModuleGraphNode] -> [ModuleGraphNode] -> [BuildPlan]
+        toBuildPlan [] mgn = collapseAcyclic (topSortWithBoot mgn)
+        toBuildPlan ((AcyclicSCC node):sccs) mgn = toBuildPlan sccs (node:mgn)
+        -- Interesting case
+        toBuildPlan ((CyclicSCC nodes):sccs) mgn =
+          let acyclic = collapseAcyclic (topSortWithBoot mgn)
+              -- Now perform another toposort but just with these nodes and relevant hs-boot files.
+              -- The result should be acyclic, if it's not, then there's an unresolved cycle in the graph.
+              mresolved_cycle = collapseSCC (topSortWithBoot nodes)
+          in acyclic ++ [maybe (UnresolvedCycle nodes) ResolvedCycle mresolved_cycle] ++ toBuildPlan sccs []
+
+        -- An environment mapping a module to its hs-boot file, if one exists
+        boot_modules = mkModuleEnv
+          [ (ms_mod ms, m) | m@(ModuleNode (ExtendedModSummary ms _)) <- (mgModSummaries' mod_graph), isBootSummary ms == IsBoot]
+
+        select_boot_modules :: [ModuleGraphNode] -> [ModuleGraphNode]
+        select_boot_modules = mapMaybe (\m -> case m of ModuleNode (ExtendedModSummary ms _) -> lookupModuleEnv boot_modules (ms_mod ms); _ -> Nothing )
+
+        -- Any cycles should be resolved now
+        collapseSCC :: [SCC ModuleGraphNode] -> Maybe [ModuleGraphNode]
+        -- Must be at least two nodes, as we were in a cycle
+        collapseSCC [AcyclicSCC node1, AcyclicSCC node2] = Just [node1, node2]
+        collapseSCC (AcyclicSCC node : nodes) = (node :) <$> collapseSCC nodes
+        -- Cyclic
+        collapseSCC _ = Nothing
+
+        -- The toposort and accumulation of acyclic modules is solely to pick-up
+        -- hs-boot files which are **not** part of cycles.
+        collapseAcyclic :: [SCC ModuleGraphNode] -> [BuildPlan]
+        collapseAcyclic (AcyclicSCC node : nodes) = SingleModule node : collapseAcyclic nodes
+        collapseAcyclic (CyclicSCC nodes : _) = [UnresolvedCycle nodes]
+        collapseAcyclic [] = []
+
+        topSortWithBoot nodes = topSortModules False (select_boot_modules nodes ++ nodes) Nothing
+
+
+  in
+
+    assertPpr (sum (map countMods build_plan) == length (mgModSummaries' mod_graph))
+              (vcat [text "Build plan missing nodes:", (text "PLAN:" <+> ppr build_plan), (text "GRAPH:" <+> ppr (mgModSummaries' mod_graph ))])
+              build_plan
+
 -- | Generalized version of 'load' which also supports a custom
 -- 'Messager' (for reporting progress) and 'ModuleGraph' (generally
 -- produced by calling 'depanal'.
@@ -442,24 +522,29 @@ load' how_much mHscMessage mod_graph = do
     checkHowMuch how_much $ do
 
     -- mg2_with_srcimps drops the hi-boot nodes, returning a
-    -- graph with cycles.  Among other things, it is used for
-    -- backing out partially complete cycles following a failed
-    -- upsweep, and for removing from hpt all the modules
-    -- not in strict downwards closure, during calls to compile.
-    let mg2_with_srcimps :: [SCC ModSummary]
-        mg2_with_srcimps = filterToposortToModules $
-          topSortModuleGraph True mod_graph Nothing
+    -- graph with cycles. It is just used for warning about unecessary source imports.
+    let mg2_with_srcimps :: [SCC ModuleGraphNode]
+        mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing
 
     -- If we can determine that any of the {-# SOURCE #-} imports
     -- are definitely unnecessary, then emit a warning.
-    warnUnnecessarySourceImports mg2_with_srcimps
+    warnUnnecessarySourceImports (filterToposortToModules mg2_with_srcimps)
+
+    let maybe_top_mod = case how_much of
+                          LoadUpTo m           -> Just m
+                          LoadDependenciesOf m -> Just m
+                          _                    -> Nothing
+
+        build_plan = createBuildPlan mod_graph maybe_top_mod
+
+
 
 
     let
         -- prune the HPT so everything is not retained when doing an
         -- upsweep.
         pruned_hpt = pruneHomePackageTable hpt1
-                            (flattenSCCs mg2_with_srcimps)
+                            (flattenSCCs (filterToposortToModules  mg2_with_srcimps))
 
     _ <- liftIO $ evaluate pruned_hpt
 
@@ -471,69 +556,29 @@ load' how_much mHscMessage mod_graph = do
     -- Unload everything
     liftIO $ unload interp hsc_env
 
-
-    -- We could at this point detect cycles which aren't broken by
-    -- a source-import, and complain immediately, but it seems better
-    -- to let upsweep_mods do this, so at least some useful work gets
-    -- done before the upsweep is abandoned.
-    --hPutStrLn stderr "after tsort:\n"
-    --hPutStrLn stderr (showSDoc (vcat (map ppr mg2)))
-
-    -- Now do the upsweep, calling compile for each module in
-    -- turn.  Final result is version 3 of everything.
-
-    -- Topologically sort the module graph, this time including hi-boot
-    -- nodes, and possibly just including the portion of the graph
-    -- reachable from the module specified in the 2nd argument to load.
-    -- This graph should be cycle-free.
-    let partial_mg0, partial_mg:: [SCC ModuleGraphNode]
-
-        maybe_top_mod = case how_much of
-                            LoadUpTo m           -> Just m
-                            LoadDependenciesOf m -> Just m
-                            _                    -> Nothing
-
-        partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod
-
-        -- LoadDependenciesOf m: we want the upsweep to stop just
-        -- short of the specified module
-        partial_mg
-            | LoadDependenciesOf _mod <- how_much
-            = assert (case last partial_mg0 of
-                        AcyclicSCC (ModuleNode (ExtendedModSummary ms _)) -> ms_mod_name ms == _mod
-                        _ -> False) $
-              List.init partial_mg0
-            | otherwise
-            = partial_mg0
-
-        mg = partial_mg
-
     liftIO $ debugTraceMsg logger 2 (hang (text "Ready for upsweep")
-                                    2 (ppr mg))
+                                    2 (ppr build_plan))
+
+    let direct_deps = mkDepsMap (mgModSummaries' mod_graph)
 
     n_jobs <- case parMakeCount dflags of
                     Nothing -> liftIO getNumProcessors
                     Just n  -> return n
-    let upsweep_fn | n_jobs > 1 = parUpsweep n_jobs
-                   | otherwise  = upsweep
 
     setSession $ hscUpdateHPT (const emptyHomePackageTable) hsc_env
-    (upsweep_ok, modsUpswept) <- withDeferredDiagnostics $
-      upsweep_fn mHscMessage pruned_hpt mg
-
-    -- Make modsDone be the summaries for each home module now
-    -- available; this should equal the domain of hpt3.
-    -- Get in in a roughly top .. bottom order (hence reverse).
+    (upsweep_ok, hsc_env1) <- withDeferredDiagnostics $
+      liftIO $ upsweep n_jobs hsc_env mHscMessage pruned_hpt direct_deps build_plan
+    setSession hsc_env1
+    case upsweep_ok of
+      Failed -> loadFinish upsweep_ok Succeeded
+      Succeeded -> do
+       -- Make modsDone be the summaries for each home module now
+       -- available; this should equal the domain of hpt3.
+       -- Get in in a roughly top .. bottom order (hence reverse).
+
+       -- Try and do linking in some form, depending on whether the
+       -- upsweep was completely or only partially successful.
 
-    let nodesDone = reverse modsUpswept
-        (_, modsDone) = partitionNodes nodesDone
-
-    -- Try and do linking in some form, depending on whether the
-    -- upsweep was completely or only partially successful.
-
-    if succeeded upsweep_ok
-
-     then
        -- Easy; just relink it all.
        do liftIO $ debugTraceMsg logger 2 (text "Upsweep completely successful.")
 
@@ -577,64 +622,6 @@ load' how_much mHscMessage mod_graph = do
              else
                 loadFinish Succeeded linkresult
 
-     else
-       -- Tricky.  We need to back out the effects of compiling any
-       -- half-done cycles, both so as to clean up the top level envs
-       -- and to avoid telling the interactive linker to link them.
-       do liftIO $ debugTraceMsg logger 2 (text "Upsweep partially successful.")
-
-          let modsDone_names
-                 = map (ms_mod . emsModSummary) modsDone
-          let mods_to_zap_names
-                 = findPartiallyCompletedCycles modsDone_names
-                      mg2_with_srcimps
-          let (mods_to_clean, mods_to_keep) =
-                partition ((`Set.member` mods_to_zap_names).ms_mod) $
-                emsModSummary <$> modsDone
-          hsc_env1 <- getSession
-          let hpt4 = hsc_HPT hsc_env1
-              -- We must change the lifetime to TFL_CurrentModule for any temp
-              -- file created for an element of mod_to_clean during the upsweep.
-              -- These include preprocessed files and object files for loaded
-              -- modules.
-              unneeded_temps = concat
-                [ms_hspp_file : object_files
-                | ModSummary{ms_mod, ms_hspp_file} <- mods_to_clean
-                , let object_files = maybe [] linkableObjs $
-                        lookupHpt hpt4 (moduleName ms_mod)
-                        >>= hm_linkable
-                ]
-          tmpfs <- hsc_tmpfs <$> getSession
-          liftIO $ changeTempFilesLifetime tmpfs TFL_CurrentModule unneeded_temps
-          liftIO $ cleanCurrentModuleTempFilesMaybe logger tmpfs dflags
-
-          let hpt5 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep)
-                                          hpt4
-
-          -- Clean up after ourselves
-
-          -- there should be no Nothings where linkables should be, now
-          let just_linkables =
-                    isNoLink (ghcLink dflags)
-                 || allHpt (isJust.hm_linkable)
-                        (filterHpt ((== HsSrcFile).mi_hsc_src.hm_iface)
-                                hpt5)
-          assert just_linkables $ do
-
-          -- Link everything together
-          hsc_env <- getSession
-          linkresult <- liftIO $ link (ghcLink dflags)
-                                      logger
-                                      (hsc_tmpfs hsc_env)
-                                      (hsc_hooks hsc_env)
-                                      dflags
-                                      (hsc_unit_env hsc_env)
-                                      False
-                                      hpt5
-
-          modifySession $ hscUpdateHPT (const hpt5)
-          loadFinish Failed linkresult
-
 partitionNodes
   :: [ModuleGraphNode]
   -> ( [InstantiatedUnit]
@@ -753,25 +740,6 @@ pruneHomePackageTable hpt summ
 
         ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ]
 
-
--- -----------------------------------------------------------------------------
---
--- | Return (names of) all those in modsDone who are part of a cycle as defined
--- by theGraph.
-findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> Set.Set Module
-findPartiallyCompletedCycles modsDone theGraph
-   = Set.unions
-       [mods_in_this_cycle
-       | CyclicSCC vs <- theGraph  -- Acyclic? Not interesting.
-       , let names_in_this_cycle = Set.fromList (map ms_mod vs)
-             mods_in_this_cycle =
-                    Set.intersection (Set.fromList modsDone) names_in_this_cycle
-         -- If size mods_in_this_cycle == size names_in_this_cycle,
-         -- then this cycle has already been completed and we're not
-         -- interested.
-       , Set.size mods_in_this_cycle < Set.size names_in_this_cycle]
-
-
 -- ---------------------------------------------------------------------------
 --
 -- | Unloading
@@ -781,734 +749,302 @@ unload interp hsc_env
         LinkInMemory -> Linker.unload interp hsc_env []
         _other -> return ()
 
--- -----------------------------------------------------------------------------
-{- |
 
-  Stability tells us which modules definitely do not need to be recompiled.
-  There are two main reasons for having stability:
+{- Parallel Upsweep
 
-   - avoid doing a complete upsweep of the module graph in GHCi when
-     modules near the bottom of the tree have not changed.
+The parallel upsweep attempts to concurrently compile the modules in the
+compilation graph using multiple Haskell threads.
+
+The Algorithm
+
+* The list of `MakeAction`s are created by `interpretBuildPlan`. A `MakeAction` is
+a pair of an `IO a` action and a `MVar a`, where to place the result.
+  The list is sorted topologically, so can be executed in order without fear of
+  blocking.
+* runPipelines takes this list and eventually passes it to runLoop which executes
+  each action and places the result into the right MVar.
+* The amount of parrelism is controlled by a semaphore. This is just used around the
+  module compilation step, so that only the right number of modules are compiled at
+  the same time which reduces overal memory usage and allocations.
+* Each proper node has a LogQueue, which dictates where to send it's output.
+* The LogQueue is placed into the LogQueueQueue when the action starts and a worker
+  thread processes the LogQueueQueue printing logs for each module in a stable order.
+* The result variable for an action producing `a` is of type `Maybe a`, therefore
+  it is still filled on a failure. If a module fails to compile, the
+  failure is propagated through the whole module graph and any modules which didn't
+  depend on the failure can still be compiled. This behaviour also makes the code
+  quite a bit cleaner.
+-}
 
-   - to tell GHCi when it can load object code: we can only load object code
-     for a module when we also load object code for all of the imports of the
-     module.  So we need to know that we will definitely not be recompiling
-     any of these modules, and we can use the object code.
 
-  The stability check is as follows.  Both stableObject and
-  stableBCO are used during the upsweep phase later.
+{-
 
-@
-  stable m = stableObject m || stableBCO m
+Note [--make mode]
+~~~~~~~~~~~~~~~~~
 
-  stableObject m =
-        all stableObject (imports m)
-        && old linkable does not exist, or is == on-disk .o
-        && date(on-disk .o) >= date(on-disk .hi)
-        && hash(on-disk .hs) == hash recorded in .hi
+There are two main parts to `--make` mode.
 
-  stableBCO m =
-        all stable (imports m)
-        && hash(on-disk .hs) == hash recorded alongside BCO
-@
+1. `downsweep`: Starts from the top of the module graph and computes dependencies.
+2. `upsweep`: Starts from the bottom of the module graph and compiles modules.
 
-  These properties embody the following ideas:
+The result of the downsweep is a 'ModuleGraph', which is then passed to 'upsweep' which
+computers how to build this ModuleGraph.
 
-    - if a module is stable, then:
+Note [Upsweep]
+~~~~~~~~~~~~~~
 
-        - if it has been compiled in a previous pass (present in HPT)
-          then it does not need to be compiled or re-linked.
+Upsweep takes a 'ModuleGraph' as input, computes a build plan and then executes
+the plan in order to compile the project.
 
-        - if it has not been compiled in a previous pass,
-          then we only need to read its .hi file from disk and
-          link it to produce a 'ModDetails'.
+The first step is computing the build plan from a 'ModuleGraph'.
 
-    - if a modules is not stable, we will definitely be at least
-      re-linking, and possibly re-compiling it during the 'upsweep'.
-      All non-stable modules can (and should) therefore be unlinked
-      before the 'upsweep'.
+The output of this step is a `[BuildPlan]`, which is a topologically sorted plan for
+how to build all the modules.
 
-    - Note that objects are only considered stable if they only depend
-      on other objects.  We can't link object code against byte code.
+```
+data BuildPlan = SingleModule ModuleGraphNode  -- A simple, single module all alone but *might* have an hs-boot file which isn't part of a cycle
+               | ResolvedCycle [ModuleGraphNode]   -- A resolved cycle, linearised by hs-boot files
+               | UnresolvedCycle [ModuleGraphNode] -- An actual cycle, which wasn't resolved by hs-boot files
+```
 
-    - Note that even if an object is stable, we may end up recompiling
-      if the interface is out of date because an *external* interface
-      has changed.  The current code in GHC.Driver.Make handles this case
-      fairly poorly, so be careful.
+The plan is computed in two steps:
 
-  See also Note [When source is considered modified]
--}
+Step 1: Topologically sort the module graph without hs-boot files. This returns a [SCC ModuleGraphNode] which contains
+        cycles.
+Step 2: For each cycle, topologically sort the modules in the cycle *with* the relevant hs-boot files. This should
+        result in an acyclic build plan if the hs-boot files are sufficient to resolve the cycle.
 
 
-{- Parallel Upsweep
- -
- - The parallel upsweep attempts to concurrently compile the modules in the
- - compilation graph using multiple Haskell threads.
- -
- - The Algorithm
- -
- - A Haskell thread is spawned for each module in the module graph, waiting for
- - its direct dependencies to finish building before it itself begins to build.
- -
- - Each module is associated with an initially empty MVar that stores the
- - result of that particular module's compile. If the compile succeeded, then
- - the HscEnv (synchronized by an MVar) is updated with the fresh HMI of that
- - module, and the module's HMI is deleted from the old HPT (synchronized by an
- - IORef) to save space.
- -
- - Instead of immediately outputting messages to the standard handles, all
- - compilation output is deferred to a per-module TQueue. A QSem is used to
- - limit the number of workers that are compiling simultaneously.
- -
- - Meanwhile, the main thread sequentially loops over all the modules in the
- - module graph, outputting the messages stored in each module's TQueue.
--}
+The `[BuildPlan]` is then interpreted by the `interpretBuildPlan` function.
 
--- | Each module is given a unique 'LogQueue' to redirect compilation messages
--- to. A 'Nothing' value contains the result of compilation, and denotes the
--- end of the message queue.
-data LogQueue = LogQueue !(IORef [Maybe (MessageClass, SrcSpan, SDoc)])
-                         !(MVar ())
-
--- | The graph of modules to compile and their corresponding result 'MVar' and
--- 'LogQueue'.
-type CompilationGraph = [(ModuleGraphNode, MVar SuccessFlag, LogQueue)]
-
--- | Build a 'CompilationGraph' out of a list of strongly-connected modules,
--- also returning the first, if any, encountered module cycle.
-buildCompGraph :: [SCC ModuleGraphNode] -> IO (CompilationGraph, Maybe [ModuleGraphNode])
-buildCompGraph [] = return ([], Nothing)
-buildCompGraph (scc:sccs) = case scc of
-    AcyclicSCC ms -> do
-        mvar <- newEmptyMVar
-        log_queue <- do
-            ref <- newIORef []
-            sem <- newEmptyMVar
-            return (LogQueue ref sem)
-        (rest,cycle) <- buildCompGraph sccs
-        return ((ms,mvar,log_queue):rest, cycle)
-    CyclicSCC mss -> return ([], Just mss)
-
--- | A Module and whether it is a boot module.
---
--- We need to treat boot modules specially when building compilation graphs,
--- since they break cycles. Regular source files and signature files are treated
--- equivalently.
-data BuildModule = BuildModule_Unit {-# UNPACK #-} !InstantiatedUnit | BuildModule_Module {-# UNPACK #-} !ModuleWithIsBoot
-  deriving (Eq, Ord)
+* SingleModule nodes are compiled normally by either the upsweep_inst or upsweep_mod functions.
+* ResolvedCycles need to compiled "together" so that the information which ends up in
+  the interface files at the end is accurate (and doesn't contain temporary information from
+  the hs-boot files.)
+  - During the initial compilation, a `KnotVars` is created which stores an IORef TypeEnv for
+    each module of the loop. These IORefs are gradually updated as the loop completes and provide
+    the required laziness to typecheck the module loop.
+  - At the end of typechecking, all the interface files are typechecked again in
+    the retypecheck loop. This time, the knot-tying is done by the normal laziness
+    based tying, so the environment is run without the KnotVars.
+* UnresolvedCycles are indicative of a proper cycle, unresolved by hs-boot files
+  and are reported as an error to the user.
 
+The main trickiness of `interpretBuildPlan` is deciding which version of a dependency
+is visible from each module. For modules which are not in a cycle, there is just
+one version of a module, so that is always used. For modules in a cycle, there are two versions of
+'HomeModInfo'.
 
-mkBuildModule :: ModuleGraphNode -> BuildModule
-mkBuildModule = \case
-  InstantiationNode x -> BuildModule_Unit x
-  ModuleNode ems -> BuildModule_Module $ mkBuildModule0 (emsModSummary ems)
+1. Internal to loop: The version created whilst compiling the loop by upsweep_mod.
+2. External to loop: The knot-tied version created by typecheckLoop.
 
-mkHomeBuildModule :: ModuleGraphNode -> NodeKey
-mkHomeBuildModule = \case
-  InstantiationNode x -> NodeKey_Unit x
-  ModuleNode ems -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary ems)
+Whilst compiling a module inside the loop, we need to use the (1). For a module which
+is outside of the loop which depends on something from in the loop, the (2) version
+is used.
 
-mkBuildModule0 :: ModSummary -> ModuleWithIsBoot
-mkBuildModule0 ms = GWIB
-  { gwib_mod = ms_mod ms
-  , gwib_isBoot = isBootSummary ms
-  }
+As the plan is interpreted, which version of a HomeModInfo is visible is updated
+by updating a map held in a state monad. So after a loop has finished being compiled,
+the visible module is the one created by typecheckLoop and the internal version is not
+used again.
 
-mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot
-mkHomeBuildModule0 ms = GWIB
-  { gwib_mod = moduleName $ ms_mod ms
-  , gwib_isBoot = isBootSummary ms
-  }
+This plan also ensures the most important invariant to do with module loops:
 
--- | The entry point to the parallel upsweep.
---
--- See also the simpler, sequential 'upsweep'.
-parUpsweep
-    :: GhcMonad m
-    => Int
-    -- ^ The number of workers we wish to run in parallel
-    -> Maybe Messager
-    -> HomePackageTable
-    -> [SCC ModuleGraphNode]
-    -> m (SuccessFlag,
-          [ModuleGraphNode])
-parUpsweep n_jobs mHscMessage old_hpt sccs = do
-    hsc_env <- getSession
-    let dflags = hsc_dflags hsc_env
-    let logger = hsc_logger hsc_env
-    let tmpfs  = hsc_tmpfs hsc_env
-
-    -- The bits of shared state we'll be using:
-
-    -- The global HscEnv is updated with the module's HMI when a module
-    -- successfully compiles.
-    hsc_env_var <- liftIO $ newMVar hsc_env
-
-    -- The old HPT is used for recompilation checking in upsweep_mod. When a
-    -- module successfully gets compiled, its HMI is pruned from the old HPT.
-    old_hpt_var <- liftIO $ newIORef old_hpt
+> If you depend on anything within a module loop, before you can use the dependency,
+  the whole loop has to finish compiling.
 
-    -- What we use to limit parallelism with.
-    par_sem <- liftIO $ newQSem n_jobs
+The end result of `interpretBuildPlan` is a `[MakeAction]`, which are pairs
+of `IO a` actions and a `MVar (Maybe a)`, somewhere to put the result of running
+the action. This list is topologically sorted, so can be run in order to compute
+the whole graph.
 
+As well as this `interpretBuildPlan` also outputs an `IO [Maybe (Maybe HomeModInfo)]` which
+can be queried at the end to get the result of all modules at the end, with their proper
+visibility. For example, if any module in a loop fails then all modules in that loop will
+report as failed because the visible node at the end will be the result of retypechecking
+those modules together.
 
-    let updNumCapabilities = liftIO $ do
-            n_capabilities <- getNumCapabilities
-            n_cpus <- getNumProcessors
-            -- Setting number of capabilities more than
-            -- CPU count usually leads to high userspace
-            -- lock contention. #9221
-            let n_caps = min n_jobs n_cpus
-            unless (n_capabilities /= 1) $ setNumCapabilities n_caps
-            return n_capabilities
-    -- Reset the number of capabilities once the upsweep ends.
-    let resetNumCapabilities orig_n = liftIO $ setNumCapabilities orig_n
-
-    MC.bracket updNumCapabilities resetNumCapabilities $ \_ -> do
-
-    -- Sync the global session with the latest HscEnv once the upsweep ends.
-    let finallySyncSession io = io `MC.finally` do
-            hsc_env <- liftIO $ readMVar hsc_env_var
-            setSession hsc_env
-
-    finallySyncSession $ do
-
-    -- Build the compilation graph out of the list of SCCs. Module cycles are
-    -- handled at the very end, after some useful work gets done. Note that
-    -- this list is topologically sorted (by virtue of 'sccs' being sorted so).
-    (comp_graph,cycle) <- liftIO $ buildCompGraph sccs
-    let comp_graph_w_idx = zip comp_graph [1..]
-
-    -- The list of all loops in the compilation graph.
-    -- NB: For convenience, the last module of each loop (aka the module that
-    -- finishes the loop) is prepended to the beginning of the loop.
-    let graph = map fstOf3 (reverse comp_graph)
-        boot_modules = mkModuleSet
-          [ms_mod ms | ModuleNode (ExtendedModSummary ms _) <- graph, isBootSummary ms == IsBoot]
-        comp_graph_loops = go graph boot_modules
-          where
-            remove ms bm = case isBootSummary ms of
-              IsBoot -> delModuleSet bm (ms_mod ms)
-              NotBoot -> bm
-            go [] _ = []
-            go (InstantiationNode _ : mss) boot_modules
-              = go mss boot_modules
-            go mg@(mnode@(ModuleNode (ExtendedModSummary ms _)) : mss) boot_modules
-              | Just loop <- getModLoop ms mg (`elemModuleSet` boot_modules)
-              = map mkBuildModule (mnode : loop) : go mss (remove ms boot_modules)
-              | otherwise
-              = go mss (remove ms boot_modules)
-
-    -- Build a Map out of the compilation graph with which we can efficiently
-    -- look up the result MVar associated with a particular home module.
-    let home_mod_map :: Map BuildModule (MVar SuccessFlag, Int)
-        home_mod_map =
-            Map.fromList [ (mkBuildModule ms, (mvar, idx))
-                         | ((ms,mvar,_),idx) <- comp_graph_w_idx ]
-
-
-    liftIO $ label_self "main --make thread"
-
-    -- Make the logger thread_safe: we only make the "log" action thread-safe in
-    -- each worker by setting a LogAction hook, so we need to make the logger
-    -- thread-safe for other actions (DumpAction, TraceAction).
-    thread_safe_logger <- liftIO $ makeThreadSafe logger
-
-    -- For each module in the module graph, spawn a worker thread that will
-    -- compile this module.
-    let { spawnWorkers = forM comp_graph_w_idx $ \((mod,!mvar,!log_queue),!mod_idx) ->
-            forkIOWithUnmask $ \unmask -> do
-                liftIO $ label_self $ unwords $ concat
-                    [ [ "worker --make thread" ]
-                    , case mod of
-                        InstantiationNode iuid ->
-                          [ "for instantiation of unit"
-                          , show $ VirtUnit iuid
-                          ]
-                        ModuleNode ems ->
-                          [ "for module"
-                          , show (moduleNameString (ms_mod_name (emsModSummary ems)))
-                          ]
-                    , ["number"
-                      , show mod_idx
-                      ]
-                    ]
-                -- Replace the default logger with one that writes each
-                -- message to the module's log_queue. The main thread will
-                -- deal with synchronously printing these messages.
-                let lcl_logger = pushLogHook (const (parLogAction log_queue)) thread_safe_logger
-
-                -- Use a local TmpFs so that we can clean up intermediate files
-                -- in a timely fashion (as soon as compilation for that module
-                -- is finished) without having to worry about accidentally
-                -- deleting a simultaneous compile's important files.
-                lcl_tmpfs <- forkTmpFsFrom tmpfs
-
-                -- Unmask asynchronous exceptions and perform the thread-local
-                -- work to compile the module (see parUpsweep_one).
-                m_res <- MC.try $ unmask $ prettyPrintGhcErrors logger $
-                  case mod of
-                    InstantiationNode iuid -> do
-                      hsc_env <- readMVar hsc_env_var
-                      liftIO $ upsweep_inst hsc_env mHscMessage mod_idx (length sccs) iuid
-                      pure Succeeded
-                    ModuleNode ems -> do
-                      let summary     = emsModSummary ems
-                      let lcl_dflags  = ms_hspp_opts summary
-                      let lcl_logger' = setLogFlags lcl_logger (initLogFlags lcl_dflags)
-                      parUpsweep_one summary home_mod_map comp_graph_loops
-                                     lcl_logger' lcl_tmpfs dflags (hsc_home_unit hsc_env)
-                                     mHscMessage
-                                     par_sem hsc_env_var old_hpt_var
-                                     mod_idx (length sccs)
-
-                res <- case m_res of
-                    Right flag -> return flag
-                    Left exc -> do
-                        -- Don't print ThreadKilled exceptions: they are used
-                        -- to kill the worker thread in the event of a user
-                        -- interrupt, and the user doesn't have to be informed
-                        -- about that.
-                        when (fromException exc /= Just ThreadKilled)
-                             (errorMsg lcl_logger (text (show exc)))
-                        return Failed
-
-                -- Populate the result MVar.
-                putMVar mvar res
+-}
 
-                -- Write the end marker to the message queue, telling the main
-                -- thread that it can stop waiting for messages from this
-                -- particular compile.
-                writeLogQueue log_queue Nothing
+-- | Simple wrapper around MVar which allows a functor instance.
+data ResultVar b = forall a . ResultVar (a -> b) (MVar (Maybe a))
+
+instance Functor ResultVar where
+  fmap f (ResultVar g var) = ResultVar (f . g) var
+
+mkResultVar :: MVar (Maybe a) -> ResultVar a
+mkResultVar = ResultVar id
+
+-- | Block until the result is ready.
+waitResult :: ResultVar a -> MaybeT IO a
+waitResult (ResultVar f var) = MaybeT (fmap f <$> readMVar var)
+
+
+data BuildLoopState = BuildLoopState { buildDep :: M.Map NodeKey (SDoc, ResultVar (Maybe HomeModInfo))
+                                          -- The current way to build a specific TNodeKey, without cycles this just points to
+                                          -- the appropiate result of compiling a module  but with
+                                          -- cycles there can be additional indirection and can point to the result of typechecking a loop
+                                     , nNODE :: Int
+                                     , hpt_var :: MVar HomePackageTable
+                                     -- A global variable which is incrementally updated with the result
+                                     -- of compiling modules.
+                                     }
+
+nodeId :: BuildM Int
+nodeId = do
+  n <- gets nNODE
+  modify (\m -> m { nNODE = n + 1 })
+  return n
+
+setModulePipeline :: NodeKey -> SDoc -> ResultVar (Maybe HomeModInfo) -> BuildM ()
+setModulePipeline mgn doc wrapped_pipeline = do
+  modify (\m -> m { buildDep = M.insert mgn (doc, wrapped_pipeline) (buildDep m) })
+
+getBuildMap :: BuildM (M.Map
+                    NodeKey (SDoc, ResultVar (Maybe HomeModInfo)))
+getBuildMap = gets buildDep
+
+type BuildM a = StateT BuildLoopState IO a
+
+
+-- | Abstraction over the operations of a semaphore which allows usage with the
+--  -j1 case
+data AbstractSem = AbstractSem { acquireSem :: IO ()
+                               , releaseSem :: IO () }
+
+withAbstractSem :: AbstractSem -> IO b -> IO b
+withAbstractSem sem = MC.bracket_ (acquireSem sem) (releaseSem sem)
+
+-- | Environment used when compiling a module
+data MakeEnv = MakeEnv { hsc_env :: HscEnv -- The basic HscEnv which will be augmented for each module
+                       , old_hpt :: HomePackageTable -- A cache of old interface files
+                       , compile_sem :: AbstractSem
+                       , lqq_var :: TVar LogQueueQueue
+                       }
+
+type RunMakeM a = ReaderT MakeEnv (MaybeT IO) a
+
+-- | Given the build plan, creates a graph which indicates where each NodeKey should
+-- get its direct dependencies from. This might not be the corresponding build action
+-- if the module participates in a loop. This step also labels each node with a number for the output.
+-- See Note [Upsweep] for a high-level description.
+interpretBuildPlan :: (NodeKey -> [NodeKey])
+                   -> [BuildPlan]
+                   -> IO ( Maybe [ModuleGraphNode] -- Is there an unresolved cycle
+                         , [MakeAction] -- Actions we need to run in order to build everything
+                         , IO [Maybe (Maybe HomeModInfo)]) -- An action to query to get all the built modules at the end.
+interpretBuildPlan deps_map plan = do
+  hpt_var <- newMVar emptyHomePackageTable
+  ((mcycle, plans), build_map) <- runStateT (buildLoop plan) (BuildLoopState M.empty 1 hpt_var)
+  return (mcycle, plans, collect_results (buildDep build_map))
 
-                -- Add the remaining files that weren't cleaned up to the
-                -- global TmpFs, for cleanup later.
-                mergeTmpFsInto lcl_tmpfs tmpfs
+  where
+    collect_results build_map = mapM (\(_doc, res_var) -> runMaybeT (waitResult res_var)) (M.elems build_map)
+
+    n_mods = sum (map countMods plan)
+
+    buildLoop :: [BuildPlan]
+              -> BuildM (Maybe [ModuleGraphNode], [MakeAction])
+    -- Build the abstract pipeline which we can execute
+    -- Building finished
+    buildLoop []           = return (Nothing, [])
+    buildLoop (plan:plans) =
+      case plan of
+        -- If there was no cycle, then typecheckLoop is not necessary
+        SingleModule m -> do
+          (one_plan, _) <- buildSingleModule Nothing m
+          (cycle, all_plans) <- buildLoop plans
+          return (cycle, one_plan : all_plans)
+
+        -- For a resolved cycle, depend on everything in the loop, then update
+        -- the cache to point to this node rather than directly to the module build
+        -- nodes
+        ResolvedCycle ms -> do
+          pipes <- buildModuleLoop ms
+          (cycle, graph) <- buildLoop plans
+          return (cycle, pipes ++ graph)
+
+        -- Can't continue past this point as the cycle is unresolved.
+        UnresolvedCycle ns -> return (Just ns, [])
+
+    buildSingleModule :: Maybe (ModuleEnv (IORef TypeEnv)) -> ModuleGraphNode -> BuildM (MakeAction, ResultVar (Maybe HomeModInfo))
+    buildSingleModule knot_var mod = do
+      mod_idx <- nodeId
+      home_mod_map <- getBuildMap
+      hpt_var <- gets hpt_var
+      -- 1. Get the transitive dependencies of this module, by looking up in the dependency map
+      let direct_deps = deps_map (mkNodeKey mod)
+          doc_build_deps = catMaybes $ map (flip M.lookup home_mod_map) direct_deps
+          build_deps = map snd doc_build_deps
+      -- 2. Set the default way to build this node, not in a loop here
+      let build_action =
+            case mod of
+              InstantiationNode iu -> const Nothing <$> executeInstantiationNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) iu
+              ModuleNode ms -> do
+                  hmi <- executeCompileNode mod_idx n_mods (wait_deps_hpt hpt_var build_deps) knot_var (emsModSummary ms)
+                  -- This global MVar is incrementally modified in order to avoid having to
+                  -- recreate the HPT before compiling each module which leads to a quadratic amount of work.
+                  liftIO $ modifyMVar_ hpt_var (return . addHomeModInfoToHpt hmi)
+                  return (Just hmi)
+
+      res_var <- liftIO newEmptyMVar
+      let result_var = mkResultVar res_var
+      setModulePipeline (mkNodeKey mod) (text "N") result_var
+      return $ (MakeAction build_action res_var, result_var)
+
+
+    buildModuleLoop :: [ModuleGraphNode] ->  BuildM [MakeAction]
+    buildModuleLoop ms = do
+      let ms_mods = mapMaybe (\case InstantiationNode {} -> Nothing; ModuleNode ems -> Just (ms_mod (emsModSummary ems))) ms
+      knot_var <- liftIO $ mkModuleEnv <$> mapM (\m -> (m,) <$> newIORef emptyNameEnv) ms_mods
+
+      -- 1. Build all the dependencies in this loop
+      (build_modules, wait_modules) <- mapAndUnzipM (buildSingleModule (Just knot_var)) ms
+      hpt_var <- gets hpt_var
+      res_var <- liftIO newEmptyMVar
+      let loop_action = do
+            hmis <- executeTypecheckLoop (readMVar hpt_var) (wait_deps wait_modules)
+            liftIO $ modifyMVar_ hpt_var (\hpt -> return $ foldl' (flip addHomeModInfoToHpt) hpt hmis)
+            return hmis
+
+
+      let fanout i = Just . (!! i) <$> mkResultVar res_var
+      -- From outside the module loop, anyone must wait for the loop to finish and then
+      -- use the result of the retypechecked iface.
+      let update_module_pipeline (m, i) = setModulePipeline (NodeKey_Module m) (text "T") (fanout i)
+
+      let ms_i = zip (mapMaybe (fmap (msKey . emsModSummary) . moduleGraphNodeModule) ms) [0..]
+      mapM update_module_pipeline ms_i
+      return $ build_modules ++ [MakeAction loop_action res_var]
 
-        -- Kill all the workers, masking interrupts (since killThread is
-        -- interruptible). XXX: This is not ideal.
-        ; killWorkers = MC.uninterruptibleMask_ . mapM_ killThread }
 
 
-    -- Spawn the workers, making sure to kill them later. Collect the results
-    -- of each compile.
-    results <- liftIO $ MC.bracket spawnWorkers killWorkers $ \_ ->
-        -- Loop over each module in the compilation graph in order, printing
-        -- each message from its log_queue.
-        forM comp_graph $ \(mod,mvar,log_queue) -> do
-            printLogs logger log_queue
-            result <- readMVar mvar
-            if succeeded result then return (Just mod) else return Nothing
 
+upsweep
+    :: Int -- ^ The number of workers we wish to run in parallel
+    -> HscEnv -- ^ The base HscEnv, which is augmented for each module
+    -> Maybe Messager
+    -> HomePackageTable
+    -> (NodeKey -> [NodeKey]) -- A function which computes the direct dependencies of a NodeKey
+    -> [BuildPlan]
+    -> IO (SuccessFlag, HscEnv)
+upsweep n_jobs hsc_env _mHscMessage old_hpt direct_deps build_plan = do
+    (cycle, pipelines, collect_result) <- interpretBuildPlan direct_deps build_plan
+    runPipelines n_jobs hsc_env old_hpt pipelines
+    res <- collect_result
 
-    -- Collect and return the ModSummaries of all the successful compiles.
-    -- NB: Reverse this list to maintain output parity with the sequential upsweep.
-    let ok_results = reverse (catMaybes results)
+    let completed = [m | Just (Just m) <- res]
+    let hsc_env' = addDepsToHscEnv completed hsc_env
 
     -- Handle any cycle in the original compilation graph and return the result
     -- of the upsweep.
     case cycle of
         Just mss -> do
-            liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)
-            return (Failed,ok_results)
+          let logger = hsc_logger hsc_env
+          liftIO $ fatalErrorMsg logger (cyclicModuleErr mss)
+          return (Failed, hsc_env)
         Nothing  -> do
-            let success_flag = successIf (all isJust results)
-            return (success_flag,ok_results)
-
-  where
-    writeLogQueue :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc) -> IO ()
-    writeLogQueue (LogQueue ref sem) msg = do
-        atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
-        _ <- tryPutMVar sem ()
-        return ()
-
-    -- The log_action callback that is used to synchronize messages from a
-    -- worker thread.
-    parLogAction :: LogQueue -> LogAction
-    parLogAction log_queue _dflags !msgClass !srcSpan !msg =
-        writeLogQueue log_queue (Just (msgClass,srcSpan,msg))
-
-    -- Print each message from the log_queue using the global logger
-    printLogs :: Logger -> LogQueue -> IO ()
-    printLogs !logger (LogQueue ref sem) = read_msgs
-      where read_msgs = do
-                takeMVar sem
-                msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
-                print_loop msgs
-
-            print_loop [] = read_msgs
-            print_loop (x:xs) = case x of
-                Just (msgClass,srcSpan,msg) -> do
-                    logMsg logger msgClass srcSpan msg
-                    print_loop xs
-                -- Exit the loop once we encounter the end marker.
-                Nothing -> return ()
-
--- The interruptible subset of the worker threads' work.
-parUpsweep_one
-    :: ModSummary
-    -- ^ The module we wish to compile
-    -> Map BuildModule (MVar SuccessFlag, Int)
-    -- ^ The map of home modules and their result MVar
-    -> [[BuildModule]]
-    -- ^ The list of all module loops within the compilation graph.
-    -> Logger
-    -- ^ The thread-local Logger
-    -> TmpFs
-    -- ^ The thread-local TmpFs
-    -> DynFlags
-    -- ^ The thread-local DynFlags
-    -> HomeUnit
-    -- ^ The home-unit
-    -> Maybe Messager
-    -- ^ The messager
-    -> QSem
-    -- ^ The semaphore for limiting the number of simultaneous compiles
-    -> MVar HscEnv
-    -- ^ The MVar that synchronizes updates to the global HscEnv
-    -> IORef HomePackageTable
-    -- ^ The old HPT
-    -> Int
-    -- ^ The index of this module
-    -> Int
-    -- ^ The total number of modules
-    -> IO SuccessFlag
-    -- ^ The result of this compile
-parUpsweep_one mod home_mod_map comp_graph_loops lcl_logger lcl_tmpfs lcl_dflags home_unit mHscMessage par_sem
-               hsc_env_var old_hpt_var mod_index num_mods = do
-
-    let this_build_mod = mkBuildModule0 mod
-
-    let home_imps     = map unLoc $ ms_home_imps mod
-    let home_src_imps = map unLoc $ ms_home_srcimps mod
-
-    -- All the textual imports of this module.
-    let textual_deps = Set.fromList $
-            zipWith f home_imps     (repeat NotBoot) ++
-            zipWith f home_src_imps (repeat IsBoot)
-          where f mn isBoot = BuildModule_Module $ GWIB
-                  { gwib_mod = mkHomeModule home_unit mn
-                  , gwib_isBoot = isBoot
-                  }
-
-    -- Dealing with module loops
-    -- ~~~~~~~~~~~~~~~~~~~~~~~~~
-    --
-    -- Not only do we have to deal with explicit textual dependencies, we also
-    -- have to deal with implicit dependencies introduced by import cycles that
-    -- are broken by an hs-boot file. We have to ensure that:
-    --
-    -- 1. A module that breaks a loop must depend on all the modules in the
-    --    loop (transitively or otherwise). This is normally always fulfilled
-    --    by the module's textual dependencies except in degenerate loops,
-    --    e.g.:
-    --
-    --    A.hs imports B.hs-boot
-    --    B.hs doesn't import A.hs
-    --    C.hs imports A.hs, B.hs
-    --
-    --    In this scenario, getModLoop will detect the module loop [A,B] but
-    --    the loop finisher B doesn't depend on A. So we have to explicitly add
-    --    A in as a dependency of B when we are compiling B.
-    --
-    -- 2. A module that depends on a module in an external loop can't proceed
-    --    until the entire loop is re-typechecked.
-    --
-    -- These two invariants have to be maintained to correctly build a
-    -- compilation graph with one or more loops.
-
-
-    -- The loop that this module will finish. After this module successfully
-    -- compiles, this loop is going to get re-typechecked.
-    let finish_loop :: Maybe [ModuleWithIsBoot]
-        finish_loop = listToMaybe
-          [ flip mapMaybe (tail loop) $ \case
-              BuildModule_Unit _ -> Nothing
-              BuildModule_Module ms -> Just ms
-          | loop <- comp_graph_loops
-          , head loop == BuildModule_Module this_build_mod
-          ]
-
-    -- If this module finishes a loop then it must depend on all the other
-    -- modules in that loop because the entire module loop is going to be
-    -- re-typechecked once this module gets compiled. These extra dependencies
-    -- are this module's "internal" loop dependencies, because this module is
-    -- inside the loop in question.
-    let int_loop_deps :: Set.Set BuildModule
-        int_loop_deps = Set.fromList $
-            case finish_loop of
-                Nothing   -> []
-                Just loop -> BuildModule_Module <$> filter (/= this_build_mod) loop
-
-    -- If this module depends on a module within a loop then it must wait for
-    -- that loop to get re-typechecked, i.e. it must wait on the module that
-    -- finishes that loop. These extra dependencies are this module's
-    -- "external" loop dependencies, because this module is outside of the
-    -- loop(s) in question.
-    let ext_loop_deps :: Set.Set BuildModule
-        ext_loop_deps = Set.fromList
-            [ head loop | loop <- comp_graph_loops
-                        , any (`Set.member` textual_deps) loop
-                        , BuildModule_Module this_build_mod `notElem` loop ]
-
-
-    let all_deps = foldl1 Set.union [textual_deps, int_loop_deps, ext_loop_deps]
-
-    -- All of the module's home-module dependencies.
-    let home_deps_with_idx =
-            [ home_dep | dep <- Set.toList all_deps
-                       , Just home_dep <- [Map.lookup dep home_mod_map]
-                       ]
-
-    -- Sort the list of dependencies in reverse-topological order. This way, by
-    -- the time we get woken up by the result of an earlier dependency,
-    -- subsequent dependencies are more likely to have finished. This step
-    -- effectively reduces the number of MVars that each thread blocks on.
-    let home_deps = map fst $ sortBy (flip (comparing snd)) home_deps_with_idx
-
-    -- Wait for the all the module's dependencies to finish building.
-    deps_ok <- allM (fmap succeeded . readMVar) home_deps
-
-    -- We can't build this module if any of its dependencies failed to build.
-    if not deps_ok
-      then return Failed
-      else do
-        -- Any hsc_env at this point is OK to use since we only really require
-        -- that the HPT contains the HMIs of our dependencies.
-        hsc_env <- readMVar hsc_env_var
-        old_hpt <- readIORef old_hpt_var
-
-        let lcl_diag_opts = initDiagOpts lcl_dflags
-        let logg err = printMessages lcl_logger lcl_diag_opts (srcErrorMessages err)
-
-        -- Limit the number of parallel compiles.
-        let withSem sem = MC.bracket_ (waitQSem sem) (signalQSem sem)
-        mb_mod_info <- withSem par_sem $
-            handleSourceError (\err -> do logg err; return Nothing) $ do
-                -- Have the HscEnv point to our local logger and tmpfs.
-                let lcl_hsc_env = localize_hsc_env hsc_env
-
-                -- Re-typecheck the loop
-                -- This is necessary to make sure the knot is tied when
-                -- we close a recursive module loop, see bug #12035.
-                type_env_var <- liftIO $ newIORef emptyNameEnv
-                let lcl_hsc_env' = lcl_hsc_env { hsc_type_env_var =
-                                    Just (ms_mod mod, type_env_var) }
-                lcl_hsc_env'' <- case finish_loop of
-                    Nothing   -> return lcl_hsc_env'
-                    -- In the non-parallel case, the retypecheck prior to
-                    -- typechecking the loop closer includes all modules
-                    -- EXCEPT the loop closer.  However, our precomputed
-                    -- SCCs include the loop closer, so we have to filter
-                    -- it out.
-                    Just loop -> typecheckLoop lcl_hsc_env' $
-                                 filter (/= moduleName (gwib_mod this_build_mod)) $
-                                 map (moduleName . gwib_mod) loop
-
-                -- Compile the module.
-                mod_info <- upsweep_mod lcl_hsc_env'' mHscMessage old_hpt
-                                        mod mod_index num_mods
-                return (Just mod_info)
-
-        case mb_mod_info of
-            Nothing -> return Failed
-            Just mod_info -> do
-                let this_mod = ms_mod_name mod
-
-                -- Prune the old HPT unless this is an hs-boot module.
-                unless (isBootSummary mod == IsBoot) $
-                    atomicModifyIORef' old_hpt_var $ \old_hpt ->
-                        (delFromHpt old_hpt this_mod, ())
-
-                -- Update and fetch the global HscEnv.
-                lcl_hsc_env' <- modifyMVar hsc_env_var $ \hsc_env -> do
-                    let hsc_env' = hscUpdateHPT (\hpt -> addToHpt hpt this_mod mod_info)
-                                                hsc_env
-
-                    -- We've finished typechecking the module, now we must
-                    -- retypecheck the loop AGAIN to ensure unfoldings are
-                    -- updated.  This time, however, we include the loop
-                    -- closer!
-                    hsc_env'' <- case finish_loop of
-                        Nothing   -> return hsc_env'
-                        Just loop -> typecheckLoop hsc_env' $
-                                     map (moduleName . gwib_mod) loop
-                    return (hsc_env'', localize_hsc_env hsc_env'')
-
-                -- Clean up any intermediate files.
-                cleanCurrentModuleTempFilesMaybe (hsc_logger lcl_hsc_env')
-                                                 (hsc_tmpfs  lcl_hsc_env')
-                                                 (hsc_dflags lcl_hsc_env')
-                return Succeeded
-
-  where
-    localize_hsc_env hsc_env
-        = hsc_env { hsc_logger = lcl_logger
-                  , hsc_tmpfs  = lcl_tmpfs
-                  }
-
--- -----------------------------------------------------------------------------
---
--- | The upsweep
---
--- This is where we compile each module in the module graph, in a pass
--- from the bottom to the top of the graph.
---
--- There better had not be any cyclic groups here -- we check for them.
-upsweep
-    :: forall m
-    .  GhcMonad m
-    => Maybe Messager
-    -> HomePackageTable            -- ^ HPT from last time round (pruned)
-    -> [SCC ModuleGraphNode]       -- ^ Mods to do (the worklist)
-    -> m (SuccessFlag,
-          [ModuleGraphNode])
-       -- ^ 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.
-
-upsweep mHscMessage old_hpt sccs = do
-   (res, done) <- upsweep' old_hpt emptyMG sccs 1 (length sccs)
-   return (res, reverse $ mgModSummaries' done)
- where
-  keep_going
-    :: [NodeKey]
-    -> HomePackageTable
-    -> ModuleGraph
-    -> [SCC ModuleGraphNode]
-    -> Int
-    -> Int
-    -> m (SuccessFlag, ModuleGraph)
-  keep_going this_mods old_hpt done mods mod_index nmods = do
-    let sum_deps ms (AcyclicSCC iuidOrMod) =
-          if any (flip elem $ unfilteredEdges False iuidOrMod) $ ms
-          then mkHomeBuildModule iuidOrMod : 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 node) = elem (mkHomeBuildModule node) dep_closure
-        prunable _ = False
-        mods' = filter (not . prunable) mods
-        nmods' = nmods - length dropped_ms
-
-    when (not $ null dropped_ms) $ do
-        logger <- getLogger
-        liftIO $ debugTraceMsg logger 2 (keepGoingPruneErr $ dropped_ms)
-    (_, done') <- upsweep' old_hpt done mods' (mod_index+1) nmods'
-    return (Failed, done')
-
-  upsweep'
-    :: HomePackageTable
-    -> ModuleGraph
-    -> [SCC ModuleGraphNode]
-    -> Int
-    -> Int
-    -> m (SuccessFlag, ModuleGraph)
-  upsweep' _old_hpt done
-     [] _ _
-     = return (Succeeded, done)
-
-  upsweep' _old_hpt done
-     (CyclicSCC ms : mods) mod_index nmods
-   = do dflags <- getSessionDynFlags
-        logger <- getLogger
-        liftIO $ fatalErrorMsg logger (cyclicModuleErr ms)
-        if gopt Opt_KeepGoing dflags
-          then keep_going (mkHomeBuildModule <$> ms) old_hpt done mods mod_index nmods
-          else return (Failed, done)
-
-  upsweep' old_hpt done
-     (AcyclicSCC (InstantiationNode iuid) : mods) mod_index nmods
-   = do hsc_env <- getSession
-        liftIO $ upsweep_inst hsc_env mHscMessage mod_index nmods iuid
-        upsweep' old_hpt done mods (mod_index+1) nmods
-
-  upsweep' old_hpt done
-     (AcyclicSCC (ModuleNode ems@(ExtendedModSummary mod _)) : mods) mod_index nmods
-   = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
-        --           show (map (moduleUserString.moduleName.mi_module.hm_iface)
-        --                     (moduleEnvElts (hsc_HPT hsc_env)))
-        let logg _mod = defaultWarnErrLogger
-
-        hsc_env <- getSession
-
-        -- Remove unwanted tmp files between compilations
-        liftIO $ cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env)
-                                                  (hsc_tmpfs  hsc_env)
-                                                  (hsc_dflags hsc_env)
-
-        -- Get ready to tie the knot
-        type_env_var <- liftIO $ newIORef emptyNameEnv
-        let hsc_env1 = hsc_env { hsc_type_env_var =
-                                    Just (ms_mod mod, type_env_var) }
-        setSession hsc_env1
-
-        -- Lazily reload the HPT modules participating in the loop.
-        -- See Note [Tying the knot]--if we don't throw out the old HPT
-        -- and reinitalize the knot-tying process, anything that was forced
-        -- while we were previously typechecking won't get updated, this
-        -- was bug #12035.
-        hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done
-        setSession hsc_env2
-
-        mb_mod_info
-            <- handleSourceError
-                   (\err -> do logg mod (Just err); return Nothing) $ do
-                 mod_info <- liftIO $ upsweep_mod hsc_env2 mHscMessage old_hpt
-                                                  mod mod_index nmods
-                 logg mod Nothing -- log warnings
-                 return (Just mod_info)
-
-        case mb_mod_info of
-          Nothing -> do
-                dflags <- getSessionDynFlags
-                if gopt Opt_KeepGoing dflags
-                  then keep_going [NodeKey_Module $ mkHomeBuildModule0 mod] old_hpt done mods mod_index nmods
-                  else return (Failed, done)
-          Just mod_info -> do
-                let this_mod = ms_mod_name mod
-
-                        -- Add new info to hsc_env
-                    hsc_env3 = (hscUpdateHPT (\hpt -> addToHpt hpt this_mod mod_info) hsc_env2)
-                                { hsc_type_env_var = Nothing }
-
-                        -- Space-saving: delete the old HPT entry
-                        -- for mod BUT if mod is a hs-boot
-                        -- node, don't delete it.  For the
-                        -- interface, the HPT entry is probably for the
-                        -- main Haskell source file.  Deleting it
-                        -- would force the real module to be recompiled
-                        -- every time.
-                    old_hpt1 = case isBootSummary mod of
-                      IsBoot -> old_hpt
-                      NotBoot -> delFromHpt old_hpt this_mod
-
-                    done' = extendMG done ems
-
-                        -- fixup our HomePackageTable after we've finished compiling
-                        -- a mutually-recursive loop.  We have to do this again
-                        -- to make sure we have the final unfoldings, which may
-                        -- not have been computed accurately in the previous
-                        -- retypecheck.
-                hsc_env4 <- liftIO $ reTypecheckLoop hsc_env3 mod done'
-                setSession hsc_env4
-
-                        -- Add any necessary entries to the static pointer
-                        -- table. See Note [Grand plan for static forms] in
-                        -- GHC.Iface.Tidy.StaticPtrTable.
-                when (backend (hsc_dflags hsc_env4) == Interpreter) $
-                    liftIO $ hscAddSptEntries hsc_env4 (Just (ms_mnwib mod))
-                                 [ spt
-                                 | Just linkable <- pure $ hm_linkable mod_info
-                                 , unlinked <- linkableUnlinked linkable
-                                 , BCOs _ spts <- pure unlinked
-                                 , spt <- spts
-                                 ]
-
-                upsweep' old_hpt1 done' mods (mod_index+1) nmods
+          let success_flag = successIf (all isJust res)
+          return (success_flag, hsc_env')
 
 upsweep_inst :: HscEnv
              -> Maybe Messager
@@ -1532,36 +1068,52 @@ upsweep_mod :: HscEnv
             -> Int  -- index of module
             -> Int  -- total number of modules
             -> IO HomeModInfo
-upsweep_mod hsc_env mHscMessage old_hpt summary mod_index nmods
-   =    let
-            old_hmi = lookupHpt old_hpt (ms_mod_name summary)
-
-            -- The old interface is ok if
-            --  a) we're compiling a source file, and the old HPT
-            --     entry is for a source file
-            --  b) we're compiling a hs-boot file
-            -- Case (b) allows an hs-boot file to get the interface of its
-            -- real source file on the second iteration of the compilation
-            -- manager, but that does no harm.  Otherwise the hs-boot file
-            -- will always be recompiled
-
-            mb_old_iface
-                = case old_hmi of
-                     Nothing                                        -> Nothing
-                     Just hm_info | isBootSummary summary == IsBoot -> Just iface
-                                  | mi_boot iface == NotBoot        -> Just iface
-                                  | otherwise                       -> Nothing
-                                   where
-                                     iface = hm_iface hm_info
-
-            compile_it :: Maybe Linkable -> IO HomeModInfo
-            compile_it  mb_linkable =
-                  compileOne' mHscMessage hsc_env summary mod_index nmods
-                             mb_old_iface mb_linkable
-
-        in
-          compile_it (old_hmi >>= hm_linkable)
-
+upsweep_mod hsc_env mHscMessage old_hpt summary mod_index nmods =  do
+  let old_hmi = lookupHpt old_hpt (ms_mod_name summary)
+
+    -- The old interface is ok if
+    --  a) we're compiling a source file, and the old HPT
+    --     entry is for a source file
+    --  b) we're compiling a hs-boot file
+    -- Case (b) allows an hs-boot file to get the interface of its
+    -- real source file on the second iteration of the compilation
+    -- manager, but that does no harm.  Otherwise the hs-boot file
+    -- will always be recompiled
+
+      mb_old_iface
+        = case old_hmi of
+             Nothing                                        -> Nothing
+             Just hm_info | isBootSummary summary == IsBoot -> Just iface
+                          | mi_boot iface == NotBoot        -> Just iface
+                          | otherwise                       -> Nothing
+                           where
+                             iface = hm_iface hm_info
+
+  hmi <- compileOne' mHscMessage hsc_env summary
+          mod_index nmods mb_old_iface (old_hmi >>= hm_linkable)
+
+  -- MP: This is a bit janky, because before you add the entries you have to extend the HPT with the module
+  -- you just compiled. Another option, would be delay adding anything until after upsweep has finished, but I
+  -- am unsure if this is sound (wrt running TH splices for example).
+  -- This function only does anything if the linkable produced is a BCO, which only happens with the
+  -- bytecode backend, no need to guard against the backend type additionally.
+  addSptEntries (hscUpdateHPT (\hpt -> addToHpt hpt (ms_mod_name summary) hmi) hsc_env)
+                (ms_mnwib summary)
+                (hm_linkable hmi)
+
+  return hmi
+
+-- | Add the entries from a BCO linkable to the SPT table, see
+-- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable.
+addSptEntries :: HscEnv -> ModuleNameWithIsBoot -> Maybe Linkable -> IO ()
+addSptEntries hsc_env mnwib mlinkable =
+  hscAddSptEntries hsc_env (Just mnwib)
+     [ spt
+     | Just linkable <- [mlinkable]
+     , unlinked <- linkableUnlinked linkable
+     , BCOs _ spts <- pure unlinked
+     , spt <- spts
+     ]
 
 {- Note [-fno-code mode]
 ~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1674,14 +1226,6 @@ Potential TODOS:
 -- incorrectly regarding non-.hi files as outdated.
 --
 
--- Filter modules in the HPT
-retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable
-retainInTopLevelEnvs keep_these hpt
-   = listToHpt   [ (mod, expectJust "retain" mb_mod_info)
-                 | mod <- keep_these
-                 , let mb_mod_info = lookupHpt hpt mod
-                 , isJust mb_mod_info ]
-
 -- ---------------------------------------------------------------------------
 -- Typecheck module loops
 {-
@@ -1701,113 +1245,29 @@ TyCons, Ids etc. defined by the real module, not the boot module.
 Fortunately re-generating a ModDetails from a ModIface is easy: the
 function GHC.IfaceToCore.typecheckIface does exactly that.
 
-Picking the modules to re-typecheck is slightly tricky.  Starting from
-the module graph consisting of the modules that have already been
-compiled, we reverse the edges (so they point from the imported module
-to the importing module), and depth-first-search from the .hs-boot
-node.  This gives us all the modules that depend transitively on the
-.hs-boot module, and those are exactly the modules that we need to
-re-typecheck.
-
 Following this fix, GHC can compile itself with --make -O2.
 -}
 
-reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv
-reTypecheckLoop hsc_env ms graph
-  | Just loop <- getModLoop ms mss appearsAsBoot
-  -- SOME hs-boot files should still
-  -- get used, just not the loop-closer.
-  , let non_boot = flip mapMaybe loop $ \case
-          InstantiationNode _ -> Nothing
-          ModuleNode ems -> do
-            let l = emsModSummary ems
-            guard $ not $ isBootSummary l == IsBoot && ms_mod l == ms_mod ms
-            pure l
-  = typecheckLoop hsc_env (map ms_mod_name non_boot)
-  | otherwise
-  = return hsc_env
-  where
-  mss = mgModSummaries' graph
-  appearsAsBoot = (`elemModuleSet` mgBootModules graph)
-
--- | Given a non-boot ModSummary @ms@ of a module, for which there exists a
--- corresponding boot file in @graph@, return the set of modules which
--- transitively depend on this boot file.  This function is slightly misnamed,
--- but its name "getModLoop" alludes to the fact that, when getModLoop is called
--- with a graph that does not contain @ms@ (non-parallel case) or is an
--- SCC with hs-boot nodes dropped (parallel-case), the modules which
--- depend on the hs-boot file are typically (but not always) the
--- modules participating in the recursive module loop.  The returned
--- list includes the hs-boot file.
---
--- Example:
---      let g represent the module graph:
---          C.hs
---          A.hs-boot imports C.hs
---          B.hs imports A.hs-boot
---          A.hs imports B.hs
---      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs]
---
---      It would also be permissible to omit A.hs from the graph,
---      in which case the result is [A.hs-boot, B.hs]
---
--- Example:
---      A counter-example to the claim that modules returned
---      by this function participate in the loop occurs here:
---
---      let g represent the module graph:
---          C.hs
---          A.hs-boot imports C.hs
---          B.hs imports A.hs-boot
---          A.hs imports B.hs
---          D.hs imports A.hs-boot
---      genModLoop A.hs g == Just [A.hs-boot, B.hs, A.hs, D.hs]
---
---      Arguably, D.hs should import A.hs, not A.hs-boot, but
---      a dependency on the boot file is not illegal.
---
-getModLoop
-  :: ModSummary
-  -> [ModuleGraphNode]
-  -> (Module -> Bool) -- check if a module appears as a boot module in 'graph'
-  -> Maybe [ModuleGraphNode]
-getModLoop ms graph appearsAsBoot
-  | isBootSummary ms == NotBoot
-  , appearsAsBoot this_mod
-  , let mss = reachableBackwards (ms_mod_name ms) graph
-  = Just mss
-  | otherwise
-  = Nothing
- where
-  this_mod = ms_mod ms
-
 -- NB: sometimes mods has duplicates; this is harmless because
 -- any duplicates get clobbered in addListToHpt and never get forced.
-typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv
-typecheckLoop hsc_env mods = do
+typecheckLoop :: HscEnv -> [HomeModInfo] -> IO [(ModuleName, HomeModInfo)]
+typecheckLoop hsc_env hmis = do
   debugTraceMsg logger 2 $
-     text "Re-typechecking loop: " <> ppr mods
-  new_hpt <-
-    fixIO $ \new_hpt -> do
+     text "Re-typechecking loop: "
+  fixIO $ \new_mods -> do
+      let new_hpt = addListToHpt old_hpt new_mods
       let new_hsc_env = hscUpdateHPT (const new_hpt) hsc_env
-      mds <- initIfaceCheck (text "typecheckLoop") new_hsc_env $
+      -- Crucial, crucial: initIfaceLoad clears the if_rec_types field.
+      mds <- initIfaceLoad new_hsc_env $
                 mapM (typecheckIface . hm_iface) hmis
-      let new_hpt = addListToHpt old_hpt
-                        (zip mods [ hmi{ hm_details = details }
-                                  | (hmi,details) <- zip hmis mds ])
-      return new_hpt
-  return (hscUpdateHPT (const new_hpt) hsc_env)
+      let new_mods = [ (mn,hmi{ hm_details = details })
+                     | (hmi,details) <- zip hmis mds
+                     , let mn = moduleName (mi_module (hm_iface hmi)) ]
+      return new_mods
+
   where
     logger  = hsc_logger hsc_env
     old_hpt = hsc_HPT hsc_env
-    hmis    = map (expectJust "typecheckLoop" . lookupHpt old_hpt) mods
-
-reachableBackwards :: ModuleName -> [ModuleGraphNode] -> [ModuleGraphNode]
-reachableBackwards mod summaries
-  = [ node_payload node | node <- reachableG (transposeG graph) root ]
-  where -- the rest just sets up the graph:
-        (graph, lookup_node) = moduleGraphNodes False summaries
-        root  = expectJust "reachableBackwards" (lookup_node $ NodeKey_Module $ GWIB mod IsBoot)
 
 -- ---------------------------------------------------------------------------
 --
@@ -1833,15 +1293,17 @@ topSortModuleGraph
 -- - @True@:    eliminate the hi-boot nodes, and instead pretend
 --              the a source-import of Foo is an import of Foo
 --              The resulting graph has no hi-boot nodes, but can be cyclic
+topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod =
+    -- stronglyConnCompG flips the original order, so if we reverse
+    -- the summaries we get a stable topological sort.
+  topSortModules drop_hs_boot_nodes (reverse $ mgModSummaries' module_graph) mb_root_mod
 
-topSortModuleGraph drop_hs_boot_nodes module_graph mb_root_mod
+topSortModules :: Bool -> [ModuleGraphNode] -> Maybe ModuleName -> [SCC ModuleGraphNode]
+topSortModules drop_hs_boot_nodes summaries mb_root_mod
   = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph
   where
-    summaries = mgModSummaries' module_graph
-    -- stronglyConnCompG flips the original order, so if we reverse
-    -- the summaries we get a stable topological sort.
     (graph, lookup_node) =
-      moduleGraphNodes drop_hs_boot_nodes (reverse summaries)
+      moduleGraphNodes drop_hs_boot_nodes summaries
 
     initial_graph = case mb_root_mod of
         Nothing -> graph
@@ -1878,14 +1340,12 @@ unfilteredEdges drop_hs_boot_nodes = \case
     InstantiationNode iuid ->
       NodeKey_Module . flip GWIB NotBoot <$> uniqDSetToList (instUnitHoles iuid)
     ModuleNode (ExtendedModSummary ms bds) ->
+      [ NodeKey_Unit inst_unit | inst_unit <- bds ] ++
       (NodeKey_Module . flip GWIB hs_boot_key . unLoc <$> ms_home_srcimps ms) ++
-      (NodeKey_Module . flip GWIB NotBoot     . unLoc <$> ms_home_imps ms) ++
       [ NodeKey_Module $ GWIB (ms_mod_name ms) IsBoot
       | not $ drop_hs_boot_nodes || ms_hsc_src ms == HsBootFile
       ] ++
-      [ NodeKey_Unit inst_unit
-      | inst_unit <- bds
-      ]
+      (NodeKey_Module . flip GWIB NotBoot     . unLoc <$> ms_home_imps ms)
   where
     -- Drop hs-boot nodes by using HsSrcFile as the key
     hs_boot_key | drop_hs_boot_nodes = NotBoot -- is regular mod or signature
@@ -1906,7 +1366,7 @@ moduleGraphNodes drop_hs_boot_nodes summaries =
 
     node_map :: NodeMap SummaryNode
     node_map = NodeMap $
-      Map.fromList [ (mkHomeBuildModule s, node)
+      Map.fromList [ (mkNodeKey s, node)
                    | node <- nodes
                    , let s = summaryNodeSummary node
                    ]
@@ -1951,24 +1411,39 @@ modNodeMapLookup k (ModNodeMap m) = Map.lookup k m
 data NodeKey = NodeKey_Unit {-# UNPACK #-} !InstantiatedUnit | NodeKey_Module {-# UNPACK #-} !ModNodeKey
   deriving (Eq, Ord)
 
+instance Outputable NodeKey where
+  ppr nk = pprNodeKey nk
+
 newtype NodeMap a = NodeMap { unNodeMap :: Map.Map NodeKey a }
   deriving (Functor, Traversable, Foldable)
 
-msKey :: ModSummary -> ModNodeKey
-msKey = mkHomeBuildModule0
-
 mkNodeKey :: ModuleGraphNode -> NodeKey
 mkNodeKey = \case
   InstantiationNode x -> NodeKey_Unit x
   ModuleNode x -> NodeKey_Module $ mkHomeBuildModule0 (emsModSummary x)
 
+mkHomeBuildModule0 :: ModSummary -> ModuleNameWithIsBoot
+mkHomeBuildModule0 ms = GWIB
+  { gwib_mod = moduleName $ ms_mod ms
+  , gwib_isBoot = isBootSummary ms
+  }
+
+msKey :: ModSummary -> ModuleNameWithIsBoot
+msKey = mkHomeBuildModule0
+
 pprNodeKey :: NodeKey -> SDoc
 pprNodeKey (NodeKey_Unit iu) = ppr iu
 pprNodeKey (NodeKey_Module mk) = ppr mk
 
 mkNodeMap :: [ExtendedModSummary] -> ModNodeMap ExtendedModSummary
 mkNodeMap summaries = ModNodeMap $ Map.fromList
-  [ (msKey $ emsModSummary s, s) | s <- summaries]
+  [ (mkHomeBuildModule0 $ emsModSummary s, s) | s <- summaries]
+
+-- | Efficiently construct a map from a NodeKey to its list of transitive dependencies
+mkDepsMap :: [ModuleGraphNode] -> (NodeKey -> [NodeKey])
+mkDepsMap nodes nk =
+  let (mg, lookup_node) = moduleGraphNodes False nodes
+  in map (mkNodeKey . node_payload) $ outgoingG mg (expectJust "mkDepsMap" (lookup_node nk))
 
 -- | If there are {-# SOURCE #-} imports between strongly connected
 -- components in the topological sort, then those imports can
@@ -2543,9 +2018,9 @@ makeNewModSummary hsc_env MakeNewModSummary{..} = do
         , ms_srcimps = pi_srcimps
         , ms_ghc_prim_import = pi_ghc_prim_import
         , ms_textual_imps =
-            pi_theimps ++
             extra_sig_imports ++
-            ((,) Nothing . noLoc <$> implicit_sigs)
+            ((,) Nothing . noLoc <$> implicit_sigs) ++
+            pi_theimps
         , ms_hs_hash = nms_src_hash
         , ms_iface_date = hi_timestamp
         , ms_hie_date = hie_timestamp
@@ -2652,12 +2127,6 @@ multiRootsErr summs@(summ1:_)
     mod = ms_mod summ1
     files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs
 
-keepGoingPruneErr :: [NodeKey] -> SDoc
-keepGoingPruneErr ms
-  = vcat (( text "-fkeep-going in use, removing the following" <+>
-            text "dependencies and continuing:"):
-          map (nest 6 . pprNodeKey) ms )
-
 cyclicModuleErr :: [ModuleGraphNode] -> SDoc
 -- From a strongly connected component we find
 -- a single cycle to report
@@ -2691,11 +2160,10 @@ cyclicModuleErr mss
       ModuleNode (ExtendedModSummary ms bds) ->
         [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = IsBoot }
         | m <- ms_home_srcimps ms ] ++
-        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }
-        | m <- ms_home_imps    ms ] ++
         [ NodeKey_Unit inst_unit
-        | inst_unit <- bds
-        ]
+        | inst_unit <- bds ] ++
+        [ NodeKey_Module $ GWIB { gwib_mod = unLoc m, gwib_isBoot = NotBoot }
+        | m <- ms_home_imps    ms ]
 
     show_path :: [ModuleGraphNode] -> SDoc
     show_path []  = panic "show_path"
@@ -2720,3 +2188,256 @@ cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags ->
 cleanCurrentModuleTempFilesMaybe logger tmpfs dflags =
   unless (gopt Opt_KeepTmpFiles dflags) $
     liftIO $ cleanCurrentModuleTempFiles logger tmpfs
+
+
+addDepsToHscEnv ::  [HomeModInfo] -> HscEnv -> HscEnv
+addDepsToHscEnv deps hsc_env =
+  hscUpdateHPT (const $ listHMIToHpt deps) hsc_env
+
+setHPT ::  HomePackageTable -> HscEnv -> HscEnv
+setHPT deps hsc_env =
+  hscUpdateHPT (const $ deps) hsc_env
+
+-- | Wrap an action to catch and handle exceptions.
+wrapAction :: HscEnv -> IO a -> IO (Maybe a)
+wrapAction hsc_env k = do
+  let lcl_logger = hsc_logger hsc_env
+      lcl_dynflags = hsc_dflags hsc_env
+  let logg err = printMessages lcl_logger (initDiagOpts lcl_dynflags) (srcErrorMessages err)
+  -- MP: It is a bit strange how prettyPrintGhcErrors handles some errors but then we handle
+  -- SourceError and ThreadKilled differently directly below. TODO: Refactor to use `catches`
+  -- directly. MP should probably use safeTry here to not catch async exceptions but that will regress performance due to
+  -- internally using forkIO.
+  mres <- MC.try $ liftIO $ prettyPrintGhcErrors lcl_logger $ k
+  case mres of
+    Right res -> return $ Just res
+    Left exc -> do
+        case fromException exc of
+          Just (err :: SourceError)
+            -> logg err
+          Nothing -> case fromException exc of
+                        Just ThreadKilled -> return ()
+                        -- Don't print ThreadKilled exceptions: they are used
+                        -- to kill the worker thread in the event of a user
+                        -- interrupt, and the user doesn't have to be informed
+                        -- about that.
+                        _ -> errorMsg lcl_logger (text (show exc))
+        return Nothing
+
+withParLog :: Int -> (HscEnv -> RunMakeM a) -> RunMakeM a
+withParLog k cont  = do
+  MakeEnv{lqq_var, hsc_env} <- ask
+  -- Make a new log queue
+  lq <- liftIO $ newLogQueue k
+  -- Add it into the LogQueueQueue
+  liftIO $ atomically $ initLogQueue lqq_var lq
+  -- Modify the logger to use the log queue
+  let lcl_logger = pushLogHook (const (parLogAction lq)) (hsc_logger hsc_env)
+      hsc_env' = hsc_env { hsc_logger = lcl_logger }
+  -- Run continuation with modified logger and then clean-up
+  cont hsc_env' `MC.finally` liftIO (finishLogQueue lq)
+
+-- Executing compilation graph nodes
+
+executeInstantiationNode :: Int
+  -> Int
+  -> RunMakeM HomePackageTable
+  -> InstantiatedUnit
+  -> RunMakeM ()
+executeInstantiationNode k n wait_deps iu = do
+    withParLog k $ \hsc_env -> do
+        -- Wait for the dependencies of this node
+        deps <- wait_deps
+        -- Output of the logger is mediated by a central worker to
+        -- avoid output interleaving
+        let lcl_hsc_env = setHPT deps hsc_env
+        lift $ MaybeT $ wrapAction lcl_hsc_env $ upsweep_inst lcl_hsc_env (Just batchMsg) k n iu
+
+executeCompileNode :: Int
+  -> Int
+  -> RunMakeM HomePackageTable
+  -> Maybe (ModuleEnv (IORef TypeEnv))
+  -> ModSummary
+  -> RunMakeM HomeModInfo
+executeCompileNode k n wait_deps mknot_var mod = do
+   MakeEnv{..} <- ask
+   let mk_mod = case ms_hsc_src mod of
+                     HsigFile ->
+                       -- MP: It is probably a bit of a misimplementation in backpack that
+                       -- compiling a signature requires an knot_var for that unit.
+                       -- If you remove this then a lot of backpack tests fail.
+                       let mod_name = homeModuleInstantiation (hsc_home_unit hsc_env) (ms_mod mod)
+                       in mkModuleEnv . (:[]) . (mod_name,) <$> newIORef emptyTypeEnv
+                     _ -> return emptyModuleEnv
+   knot_var <- liftIO $ maybe mk_mod return mknot_var
+   deps <- wait_deps
+   withParLog k $ \hsc_env -> do
+     let -- Use the cached DynFlags which includes OPTIONS_GHC pragmas
+         lcl_dynflags = ms_hspp_opts mod
+     let lcl_hsc_env =
+             -- Localise the hsc_env to use the cached flags
+             setHPT deps $
+             hscSetFlags lcl_dynflags $
+             hsc_env { hsc_type_env_vars = knotVarsFromModuleEnv knot_var }
+     -- Compile the module, locking with a semphore to avoid too many modules
+     -- being compiled at the same time leading to high memory usage.
+     lift $ MaybeT (withAbstractSem compile_sem $ wrapAction lcl_hsc_env $ upsweep_mod lcl_hsc_env (Just batchMsg) old_hpt mod k n)
+
+executeTypecheckLoop :: IO HomePackageTable -- Dependencies of the loop
+  -> RunMakeM [HomeModInfo] -- The loop itself
+  -> RunMakeM [HomeModInfo]
+executeTypecheckLoop wait_other_deps wait_local_deps = do
+      hsc_env <- asks hsc_env
+      hmis <- wait_local_deps
+      other_deps <- liftIO wait_other_deps
+      let lcl_hsc_env = setHPT other_deps hsc_env
+      -- Notice that we do **not** have to pass the knot variables into this function.
+      -- That's the whole point of typecheckLoop, to replace the IORef calls with normal
+      -- knot-tying.
+      lift $ MaybeT $ Just . map snd <$> typecheckLoop lcl_hsc_env hmis
+
+-- | Wait for some dependencies to finish and then read from the given MVar.
+wait_deps_hpt :: MVar b -> [ResultVar (Maybe HomeModInfo)] -> ReaderT MakeEnv (MaybeT IO) b
+wait_deps_hpt hpt_var deps = do
+  _ <- wait_deps deps
+  liftIO $ readMVar hpt_var
+
+
+-- | Wait for dependencies to finish, and then return their results.
+wait_deps :: [ResultVar (Maybe HomeModInfo)] -> RunMakeM [HomeModInfo]
+wait_deps [] = return []
+wait_deps (x:xs) = do
+  res <- lift $ waitResult x
+  case res of
+    Nothing -> wait_deps xs
+    Just hmi -> (hmi:) <$> wait_deps xs
+
+
+-- Executing the pipelines
+
+-- | Start a thread which reads from the LogQueueQueue
+logThread :: Logger -> TVar Bool -- Signal that no more new logs will be added, clear the queue and exit
+                    -> TVar LogQueueQueue -- Queue for logs
+                    -> IO (IO ())
+logThread logger stopped lqq_var = do
+  finished_var <- newEmptyMVar
+  _ <- forkIO $ print_logs *> putMVar finished_var ()
+  return (takeMVar finished_var)
+  where
+    finish = mapM (printLogs logger)
+
+    print_logs = join $ atomically $ do
+      lqq <- readTVar lqq_var
+      case dequeueLogQueueQueue lqq of
+        Just (lq, lqq') -> do
+          writeTVar lqq_var lqq'
+          return (printLogs logger lq *> print_logs)
+        Nothing -> do
+          -- No log to print, check if we are finished.
+          stopped <- readTVar stopped
+          if not stopped then retry
+                         else return (finish (allLogQueues lqq))
+
+
+label_self :: String -> IO ()
+label_self thread_name = do
+    self_tid <- CC.myThreadId
+    CC.labelThread self_tid thread_name
+
+-- | Build and run a pipeline
+runPipelines :: Int              -- ^ How many capabilities to use
+             -> HscEnv           -- ^ The basic HscEnv which is augmented with specific info for each module
+             -> HomePackageTable -- ^ The old HPT which is used as a cache (TODO: The cache should be from the ActionMap)
+             -> [MakeAction]  -- ^ The build plan for all the module nodes
+             -> IO ()
+runPipelines n_jobs orig_hsc_env old_hpt all_pipelines = do
+
+  liftIO $ label_self "main --make thread"
+
+  -- A variable which we write to when an error has happened and we have to tell the
+  -- logging thread to gracefully shut down.
+  stopped_var <- newTVarIO False
+  -- The queue of LogQueues which actions are able to write to. When an action starts it
+  -- will add it's LogQueue into this queue.
+  log_queue_queue_var <- newTVarIO newLogQueueQueue
+  -- Thread which coordinates the printing of logs
+  wait_log_thread <- logThread (hsc_logger orig_hsc_env) stopped_var log_queue_queue_var
+
+
+  -- Make the logger thread-safe, in case there is some output which isn't sent via the LogQueue.
+  thread_safe_logger <- liftIO $ makeThreadSafe (hsc_logger orig_hsc_env)
+  let thread_safe_hsc_env = orig_hsc_env { hsc_logger = thread_safe_logger }
+
+  let updNumCapabilities = liftIO $ do
+          n_capabilities <- getNumCapabilities
+          n_cpus <- getNumProcessors
+          -- Setting number of capabilities more than
+          -- CPU count usually leads to high userspace
+          -- lock contention. #9221
+          let n_caps = min n_jobs n_cpus
+          unless (n_capabilities /= 1) $ setNumCapabilities n_caps
+          return n_capabilities
+
+  let resetNumCapabilities orig_n = do
+          liftIO $ setNumCapabilities orig_n
+          atomically $ writeTVar stopped_var True
+          wait_log_thread
+
+  abstract_sem <-
+    case n_jobs of
+      1 -> return $ AbstractSem (return ()) (return ())
+      _ -> do
+        compile_sem <- newQSem n_jobs
+        return $ AbstractSem (waitQSem compile_sem) (signalQSem compile_sem)
+    -- Reset the number of capabilities once the upsweep ends.
+  let env = MakeEnv { hsc_env = thread_safe_hsc_env
+                    , old_hpt = old_hpt
+                    , lqq_var = log_queue_queue_var
+                    , compile_sem = abstract_sem
+                    }
+
+  MC.bracket updNumCapabilities resetNumCapabilities $ \_ ->
+    runAllPipelines n_jobs env all_pipelines
+
+withLocalTmpFS :: RunMakeM a -> RunMakeM a
+withLocalTmpFS act = do
+  let initialiser = do
+        MakeEnv{..} <- ask
+        lcl_tmpfs <- liftIO $ forkTmpFsFrom (hsc_tmpfs hsc_env)
+        return $ hsc_env { hsc_tmpfs  = lcl_tmpfs }
+      finaliser lcl_env = do
+        gbl_env <- ask
+        liftIO $ mergeTmpFsInto (hsc_tmpfs lcl_env) (hsc_tmpfs (hsc_env gbl_env))
+       -- Add remaining files which weren't cleaned up into local tmp fs for
+       -- clean-up later.
+       -- Clear the logQueue if this node had it's own log queue
+  MC.bracket initialiser finaliser $ \lcl_hsc_env -> local (\env -> env { hsc_env = lcl_hsc_env}) act
+
+-- | Run the given actions and then wait for them all to finish.
+runAllPipelines :: Int -> MakeEnv -> [MakeAction] -> IO ()
+runAllPipelines n_jobs env acts = do
+  if n_jobs == 1
+    then runLoop id env acts
+    else do
+      runLoop (void . forkIO) env acts
+  mapM_ waitMakeAction acts
+
+-- | Execute each action in order, limiting the amount of parrelism by the given
+-- semaphore.
+runLoop :: (IO () -> IO ()) -> MakeEnv -> [MakeAction] -> IO ()
+runLoop _ _env [] = return ()
+runLoop fork_thread env (MakeAction act res_var :acts) = do
+  _new_thread <-
+    fork_thread $ (do
+            mres <- (run_pipeline (withLocalTmpFS act))
+                      `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.
+            putMVar res_var mres)
+  runLoop fork_thread env acts
+  where
+      run_pipeline :: RunMakeM a -> IO (Maybe a)
+      run_pipeline p = runMaybeT (runReaderT p env)
+
+data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))
+
+waitMakeAction :: MakeAction -> IO ()
+waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar
diff --git a/compiler/GHC/Driver/Monad.hs b/compiler/GHC/Driver/Monad.hs
index 41a06d4485..bfe7e0feb8 100644
--- a/compiler/GHC/Driver/Monad.hs
+++ b/compiler/GHC/Driver/Monad.hs
@@ -242,15 +242,15 @@ instance ExceptionMonad m => GhcMonad (GhcT m) where
 
 -- | Print the all diagnostics in a 'SourceError'.  Useful inside exception
 --   handlers.
-printException :: GhcMonad m => SourceError -> m ()
+printException :: (HasLogger m, MonadIO m, HasDynFlags m) => SourceError -> m ()
 printException err = do
-  dflags <- getSessionDynFlags
+  dflags <- getDynFlags
   logger <- getLogger
   let !diag_opts = initDiagOpts dflags
   liftIO $ printMessages logger diag_opts (srcErrorMessages err)
 
 -- | A function called to log warnings and errors.
-type WarnErrLogger = forall m. GhcMonad m => Maybe SourceError -> m ()
+type WarnErrLogger = forall m. (HasDynFlags m , MonadIO m, HasLogger m) => Maybe SourceError -> m ()
 
 defaultWarnErrLogger :: WarnErrLogger
 defaultWarnErrLogger Nothing  = return ()
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index cd8205f6ad..4f27c99d26 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -242,10 +242,10 @@ compileOne' mHscMessage
    status <- hscRecompStatus mHscMessage plugin_hsc_env summary
                 mb_old_iface mb_old_linkable (mod_index, nmods)
    let pipeline = hscPipeline pipe_env (setDumpPrefix pipe_env plugin_hsc_env, summary, status)
-   (iface, old_linkable) <- runPipeline (hsc_hooks hsc_env) pipeline
+   (iface, linkable) <- runPipeline (hsc_hooks hsc_env) pipeline
    -- See Note [ModDetails and --make mode]
    details <- initModDetails plugin_hsc_env summary iface
-   return $! HomeModInfo iface details old_linkable
+   return $! HomeModInfo iface details linkable
 
  where lcl_dflags  = ms_hspp_opts summary
        location    = ms_location summary
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 997cddf121..370fde59a8 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -79,6 +79,8 @@ import GHC.Linker.ExtraObj
 import GHC.Linker.Dynamic
 import Data.Version
 import GHC.Utils.Panic
+import GHC.Unit.Module.Env
+import GHC.Driver.Env.KnotVars
 
 newtype HookedUse a = HookedUse { runHookedUse :: (Hooks, PhaseHook) -> IO a }
   deriving (Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch) via (ReaderT (Hooks, PhaseHook) IO)
@@ -693,7 +695,7 @@ runHscPhase pipe_env hsc_env0 input_fn src_flavour = do
   -- files. See GHC.Tc.Utils.TcGblEnv.tcg_type_env_var.
   -- See also Note [hsc_type_env_var hack]
   type_env_var <- newIORef emptyNameEnv
-  let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_var = Just (mod, type_env_var) }
+  let plugin_hsc_env = plugin_hsc_env' { hsc_type_env_vars = knotVarsFromModuleEnv (mkModuleEnv [(mod, type_env_var)]) }
 
   status <- hscRecompStatus (Just msg) plugin_hsc_env mod_summary
                         Nothing Nothing (1, 1)
diff --git a/compiler/GHC/Driver/Pipeline/LogQueue.hs b/compiler/GHC/Driver/Pipeline/LogQueue.hs
new file mode 100644
index 0000000000..55026d8669
--- /dev/null
+++ b/compiler/GHC/Driver/Pipeline/LogQueue.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DerivingVia #-}
+module GHC.Driver.Pipeline.LogQueue ( LogQueue(..)
+                                  , newLogQueue
+                                  , finishLogQueue
+                                  , writeLogQueue
+                                  , parLogAction
+                                  , printLogs
+
+                                  , LogQueueQueue(..)
+                                  , initLogQueue
+                                  , allLogQueues
+                                  , newLogQueueQueue
+                                  , dequeueLogQueueQueue
+                                  ) where
+
+import GHC.Prelude
+import Control.Concurrent
+import Data.IORef
+import GHC.Types.Error
+import GHC.Types.SrcLoc
+import GHC.Utils.Logger
+import qualified Data.IntMap as IM
+import Control.Concurrent.STM
+
+-- LogQueue Abstraction
+
+-- | Each module is given a unique 'LogQueue' to redirect compilation messages
+-- to. A 'Nothing' value contains the result of compilation, and denotes the
+-- end of the message queue.
+data LogQueue = LogQueue { logQueueId :: !Int
+                         , logQueueMessages :: !(IORef [Maybe (MessageClass, SrcSpan, SDoc, LogFlags)])
+                         , logQueueSemaphore :: !(MVar ())
+                         }
+
+newLogQueue :: Int -> IO LogQueue
+newLogQueue n = do
+  mqueue <- newIORef []
+  sem <- newMVar ()
+  return (LogQueue n mqueue sem)
+
+finishLogQueue :: LogQueue -> IO ()
+finishLogQueue lq = do
+  writeLogQueueInternal lq Nothing
+
+
+writeLogQueue :: LogQueue -> (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
+writeLogQueue lq msg = do
+  writeLogQueueInternal lq (Just msg)
+
+-- | Internal helper for writing log messages
+writeLogQueueInternal :: LogQueue -> Maybe (MessageClass,SrcSpan,SDoc, LogFlags) -> IO ()
+writeLogQueueInternal (LogQueue _n ref sem) msg = do
+    atomicModifyIORef' ref $ \msgs -> (msg:msgs,())
+    _ <- tryPutMVar sem ()
+    return ()
+
+-- The log_action callback that is used to synchronize messages from a
+-- worker thread.
+parLogAction :: LogQueue -> LogAction
+parLogAction log_queue log_flags !msgClass !srcSpan !msg =
+    writeLogQueue log_queue (msgClass,srcSpan,msg, log_flags)
+
+-- Print each message from the log_queue using the global logger
+printLogs :: Logger -> LogQueue -> IO ()
+printLogs !logger (LogQueue _n ref sem) = read_msgs
+  where read_msgs = do
+            takeMVar sem
+            msgs <- atomicModifyIORef' ref $ \xs -> ([], reverse xs)
+            print_loop msgs
+
+        print_loop [] = read_msgs
+        print_loop (x:xs) = case x of
+            Just (msgClass,srcSpan,msg,flags) -> do
+                logMsg (setLogFlags logger flags) msgClass srcSpan msg
+                print_loop xs
+            -- Exit the loop once we encounter the end marker.
+            Nothing -> return ()
+
+-- The LogQueueQueue abstraction
+
+data LogQueueQueue = LogQueueQueue Int (IM.IntMap LogQueue)
+
+newLogQueueQueue :: LogQueueQueue
+newLogQueueQueue = LogQueueQueue 1 IM.empty
+
+addToQueueQueue :: LogQueue -> LogQueueQueue -> LogQueueQueue
+addToQueueQueue lq (LogQueueQueue n im) = LogQueueQueue n (IM.insert (logQueueId lq) lq im)
+
+initLogQueue :: TVar LogQueueQueue -> LogQueue -> STM ()
+initLogQueue lqq lq = modifyTVar lqq (addToQueueQueue lq)
+
+-- | Return all items in the queue in ascending order
+allLogQueues :: LogQueueQueue -> [LogQueue]
+allLogQueues (LogQueueQueue _n im) = IM.elems im
+
+dequeueLogQueueQueue :: LogQueueQueue -> Maybe (LogQueue, LogQueueQueue)
+dequeueLogQueueQueue (LogQueueQueue n lqq) = case IM.minViewWithKey lqq of
+                                                Just ((k, v), lqq') | k == n -> Just (v, LogQueueQueue (n + 1) lqq')
+                                                _ -> Nothing
+
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index 9ae0b78418..84a9e9a9e5 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -114,6 +114,7 @@ import GHC.Utils.Panic
 import qualified GHC.Data.Strict as Strict
 
 import Data.IORef
+import GHC.Driver.Env.KnotVars
 
 {-
 ************************************************************************
@@ -330,8 +331,14 @@ mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
          -> (DsGblEnv, DsLclEnv)
 mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
          next_wrapper_num complete_matches
-  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
-                             if_rec_types = Just (mod, return type_env) }
+  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs"
+  -- Failing tests here are `ghci` and `T11985` if you get this wrong.
+  -- this is very very "at a distance" because the reason for this check is that the type_env in interactive
+  -- mode is the smushed together of all the interactive modules.
+  -- See Note [Why is KnotVars not a ModuleEnv]
+                             , if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod
+                                                          then Just (return type_env)
+                                                          else Nothing) }
         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
                              NotBoot
         real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
diff --git a/compiler/GHC/Iface/Load.hs b/compiler/GHC/Iface/Load.hs
index 5f47ef2431..dc993aa261 100644
--- a/compiler/GHC/Iface/Load.hs
+++ b/compiler/GHC/Iface/Load.hs
@@ -119,6 +119,7 @@ import qualified Data.Set as Set
 import Data.Set (Set)
 import System.FilePath
 import System.Directory
+import GHC.Driver.Env.KnotVars
 
 {-
 ************************************************************************
@@ -533,7 +534,8 @@ loadInterface doc_str mod from
                               }
                }
 
-        ; let bad_boot = mi_boot iface == IsBoot && fmap fst (if_rec_types gbl_env) == Just mod
+        ; let bad_boot = mi_boot iface == IsBoot
+                          && isJust (lookupKnotVars (if_rec_types gbl_env) mod)
                             -- Warn against an EPS-updating import
                             -- of one's own boot file! (one-shot only)
                             -- See Note [Loading your own hi-boot file]
diff --git a/compiler/GHC/IfaceToCore.hs b/compiler/GHC/IfaceToCore.hs
index bbb1fb52c3..6806c887cc 100644
--- a/compiler/GHC/IfaceToCore.hs
+++ b/compiler/GHC/IfaceToCore.hs
@@ -8,6 +8,7 @@ Type checking of type signatures in interface files
 
 
 {-# LANGUAGE NondecreasingIndentation #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
 
@@ -110,6 +111,7 @@ import qualified GHC.Data.BooleanFormula as BF
 
 import Control.Monad
 import GHC.Parser.Annotation
+import GHC.Driver.Env.KnotVars
 
 {-
 This module takes
@@ -381,8 +383,8 @@ mergeIfaceDecls = plusOccEnv_C mergeIfaceDecl
 -- type synonym.  Perhaps this should be relaxed, where a type synonym
 -- in a signature is considered implemented by a data type declaration
 -- which matches the reference of the type synonym.
-typecheckIfacesForMerging :: Module -> [ModIface] -> IORef TypeEnv -> IfM lcl (TypeEnv, [ModDetails])
-typecheckIfacesForMerging mod ifaces tc_env_var =
+typecheckIfacesForMerging :: Module -> [ModIface] -> (KnotVars (IORef TypeEnv)) -> IfM lcl (TypeEnv, [ModDetails])
+typecheckIfacesForMerging mod ifaces tc_env_vars =
   -- cannot be boot (False)
   initIfaceLcl mod (text "typecheckIfacesForMerging") NotBoot $ do
     ignore_prags <- goptM Opt_IgnoreInterfacePragmas
@@ -404,7 +406,9 @@ typecheckIfacesForMerging mod ifaces tc_env_var =
     names_w_things <- tcIfaceDecls ignore_prags (map (\x -> (fingerprint0, x))
                                                   (occEnvElts decl_env))
     let global_type_env = mkNameEnv names_w_things
-    writeMutVar tc_env_var global_type_env
+    case lookupKnotVars tc_env_vars mod of
+      Just tc_env_var -> writeMutVar tc_env_var global_type_env
+      Nothing -> return ()
 
     -- OK, now typecheck each ModIface using this environment
     details <- forM ifaces $ \iface -> do
@@ -1775,14 +1779,11 @@ tcPragExpr is_compulsory toplvl name expr
     get_in_scope :: IfL VarSet -- Totally disgusting; but just for linting
     get_in_scope
         = do { (gbl_env, lcl_env) <- getEnvs
-             ; rec_ids <- case if_rec_types gbl_env of
-                            Nothing -> return []
-                            Just (_, get_env) -> do
-                               { type_env <- setLclEnv () get_env
-                               ; return (typeEnvIds type_env) }
+             ; let type_envs = knotVarElems (if_rec_types gbl_env)
+             ; top_level_vars <- concat <$> mapM (fmap typeEnvIds . setLclEnv ())  type_envs
              ; return (bindingsVars (if_tv_env lcl_env) `unionVarSet`
                        bindingsVars (if_id_env lcl_env) `unionVarSet`
-                       mkVarSet rec_ids) }
+                       mkVarSet top_level_vars) }
 
     bindingsVars :: FastStringEnv Var -> VarSet
     bindingsVars ufm = mkVarSet $ nonDetEltsUFM ufm
@@ -1812,10 +1813,10 @@ tcIfaceGlobal name
 
   | otherwise
   = do  { env <- getGblEnv
-        ; case if_rec_types env of {    -- Note [Tying the knot]
-            Just (mod, get_type_env)
-                | nameIsLocalOrFrom mod name
-                -> do           -- It's defined in the module being compiled
+        ; cur_mod <- if_mod <$> getLclEnv
+        ; case lookupKnotVars (if_rec_types env) (fromMaybe cur_mod (nameModule_maybe name))  of     -- Note [Tying the knot]
+            Just get_type_env
+                -> do           -- It's defined in a module in the hs-boot loop
                 { type_env <- setLclEnv () get_type_env         -- yuk
                 ; case lookupNameEnv type_env name of
                     Just thing -> return thing
@@ -1823,7 +1824,7 @@ tcIfaceGlobal name
                     Nothing   -> via_external
                 }
 
-          ; _ -> via_external }}
+            _ -> via_external }
   where
     via_external =  do
         { hsc_env <- getTopEnv
diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs
index 684bee4a59..2894321546 100644
--- a/compiler/GHC/Tc/Types.hs
+++ b/compiler/GHC/Tc/Types.hs
@@ -165,6 +165,7 @@ import GHCi.Message
 import GHCi.RemoteTypes
 
 import qualified Language.Haskell.TH as TH
+import GHC.Driver.Env.KnotVars
 
 -- | A 'NameShape' is a substitution on 'Name's that can be used
 -- to refine the identities of a hole while we are renaming interfaces
@@ -308,7 +309,7 @@ data IfGblEnv
         -- We need the module name so we can test when it's appropriate
         -- to look in this env.
         -- See Note [Tying the knot] in GHC.IfaceToCore
-        if_rec_types :: Maybe (Module, IfG TypeEnv)
+        if_rec_types :: !(KnotVars (IfG TypeEnv))
                 -- Allows a read effect, so it can be in a mutable
                 -- variable; c.f. handling the external package type env
                 -- Nothing => interactive stuff, no loops possible
@@ -321,7 +322,7 @@ data IfLclEnv
         -- it means M.f = \x -> x, where M is the if_mod
         -- NB: This is a semantic module, see
         -- Note [Identity versus semantic module]
-        if_mod :: Module,
+        if_mod :: !Module,
 
         -- Whether or not the IfaceDecl came from a boot
         -- file or not; we'll use this to choose between
@@ -443,7 +444,7 @@ data TcGblEnv
           -- NB: for what "things in this module" means, see
           -- Note [The interactive package] in "GHC.Runtime.Context"
 
-        tcg_type_env_var :: TcRef TypeEnv,
+        tcg_type_env_var :: KnotVars (IORef TypeEnv),
                 -- Used only to initialise the interface-file
                 -- typechecker in initIfaceTcRn, so that it can see stuff
                 -- bound in this module when dealing with hi-boot recursions
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index f291c57ff9..65785fc822 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -135,6 +135,7 @@ import qualified GHC.LanguageExtensions as LangExt
 import Data.IORef
 import Data.List (intercalate)
 import Control.Monad
+import GHC.Driver.Env.KnotVars
 
 {- *********************************************************************
 *                                                                      *
@@ -365,7 +366,9 @@ setGlobalTypeEnv :: TcGblEnv -> TypeEnv -> TcM TcGblEnv
 --                  * the tcg_type_env_var field seen by interface files
 setGlobalTypeEnv tcg_env new_type_env
   = do  {     -- Sync the type-envt variable seen by interface files
-           writeMutVar (tcg_type_env_var tcg_env) new_type_env
+         ; case lookupKnotVars (tcg_type_env_var tcg_env) (tcg_mod tcg_env) of
+              Just tcg_env_var -> writeMutVar tcg_env_var new_type_env
+              Nothing -> return ()
          ; return (tcg_env { tcg_type_env = new_type_env }) }
 
 
diff --git a/compiler/GHC/Tc/Utils/Monad.hs b/compiler/GHC/Tc/Utils/Monad.hs
index 1645333f32..1c5e79013d 100644
--- a/compiler/GHC/Tc/Utils/Monad.hs
+++ b/compiler/GHC/Tc/Utils/Monad.hs
@@ -133,6 +133,7 @@ module GHC.Tc.Utils.Monad(
   initIfaceLcl,
   initIfaceLclWithSubst,
   initIfaceLoad,
+  initIfaceLoadModule,
   getIfModule,
   failIfM,
   forkM_maybe,
@@ -221,6 +222,7 @@ import GHC.Tc.Errors.Types
 import {-# SOURCE #-} GHC.Tc.Utils.Env    ( tcInitTidyEnv )
 
 import qualified Data.Map as Map
+import GHC.Driver.Env.KnotVars
 
 {-
 ************************************************************************
@@ -249,9 +251,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
         infer_var    <- newIORef True ;
         infer_reasons_var <- newIORef emptyMessages ;
         dfun_n_var   <- newIORef emptyOccSet ;
-        type_env_var <- case hsc_type_env_var hsc_env of {
-                           Just (_mod, te_var) -> return te_var ;
-                           Nothing             -> newIORef emptyNameEnv } ;
+        let { type_env_var = hsc_type_env_vars hsc_env };
 
         dependent_files_var <- newIORef [] ;
         static_wc_var       <- newIORef emptyWC ;
@@ -2063,8 +2063,8 @@ initIfaceTcRn thing_inside
   = do  { tcg_env <- getGblEnv
         ; hsc_env <- getTopEnv
           -- bangs to avoid leaking the envs (#19356)
-        ; let !mod = tcg_semantic_mod tcg_env
-              !home_unit = hsc_home_unit hsc_env
+        ; let !home_unit = hsc_home_unit hsc_env
+              !knot_vars = tcg_type_env_var tcg_env
               -- When we are instantiating a signature, we DEFINITELY
               -- do not want to knot tie.
               is_instantiate = isHomeUnitInstantiating home_unit
@@ -2072,21 +2072,30 @@ initIfaceTcRn thing_inside
                             if_doc = text "initIfaceTcRn",
                             if_rec_types =
                                 if is_instantiate
-                                    then Nothing
-                                    else Just (mod, get_type_env)
+                                    then emptyKnotVars
+                                    else readTcRef <$> knot_vars
+                            }
                          }
-              ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
         ; setEnvs (if_env, ()) thing_inside }
 
--- Used when sucking in a ModIface into a ModDetails to put in
--- the HPT.  Notably, unlike initIfaceCheck, this does NOT use
--- hsc_type_env_var (since we're not actually going to typecheck,
--- so this variable will never get updated!)
+-- | 'initIfaceLoad' can be used when there's no chance that the action will
+-- call 'typecheckIface' when inside a module loop and hence 'tcIfaceGlobal'.
 initIfaceLoad :: HscEnv -> IfG a -> IO a
 initIfaceLoad hsc_env do_this
  = do let gbl_env = IfGblEnv {
                         if_doc = text "initIfaceLoad",
-                        if_rec_types = Nothing
+                        if_rec_types = emptyKnotVars
+                    }
+      initTcRnIf 'i' hsc_env gbl_env () do_this
+
+-- | This is used when we are doing to call 'typecheckModule' on an 'ModIface',
+-- if it's part of a loop with some other modules then we need to use their
+-- IORef TypeEnv vars when typechecking but crucially not our own.
+initIfaceLoadModule :: HscEnv -> Module -> IfG a -> IO a
+initIfaceLoadModule hsc_env this_mod do_this
+ = do let gbl_env = IfGblEnv {
+                        if_doc = text "initIfaceLoadModule",
+                        if_rec_types = readTcRef <$> knotVarsWithout this_mod (hsc_type_env_vars hsc_env)
                     }
       initTcRnIf 'i' hsc_env gbl_env () do_this
 
@@ -2094,12 +2103,9 @@ initIfaceCheck :: SDoc -> HscEnv -> IfG a -> IO a
 -- Used when checking the up-to-date-ness of the old Iface
 -- Initialise the environment with no useful info at all
 initIfaceCheck doc hsc_env do_this
- = do let rec_types = case hsc_type_env_var hsc_env of
-                         Just (mod,var) -> Just (mod, readTcRef var)
-                         Nothing        -> Nothing
-          gbl_env = IfGblEnv {
+ = do let gbl_env = IfGblEnv {
                         if_doc = text "initIfaceCheck" <+> doc,
-                        if_rec_types = rec_types
+                        if_rec_types = readTcRef <$> hsc_type_env_vars hsc_env
                     }
       initTcRnIf 'i' hsc_env gbl_env () do_this
 
diff --git a/compiler/GHC/Types/Var.hs-boot b/compiler/GHC/Types/Var.hs-boot
index 664aabfa2f..f96157540a 100644
--- a/compiler/GHC/Types/Var.hs-boot
+++ b/compiler/GHC/Types/Var.hs-boot
@@ -1,3 +1,4 @@
+{-# LANGUAGE NoPolyKinds #-}
 module GHC.Types.Var where
 
 import GHC.Prelude ()
diff --git a/compiler/GHC/Unit/Home/ModInfo.hs b/compiler/GHC/Unit/Home/ModInfo.hs
index fd97689972..3450844cb5 100644
--- a/compiler/GHC/Unit/Home/ModInfo.hs
+++ b/compiler/GHC/Unit/Home/ModInfo.hs
@@ -10,10 +10,12 @@ module GHC.Unit.Home.ModInfo
    , mapHpt
    , delFromHpt
    , addToHpt
+   , addHomeModInfoToHpt
    , addListToHpt
    , lookupHptDirectly
    , lookupHptByModule
    , listToHpt
+   , listHMIToHpt
    , pprHPT
    )
 where
@@ -30,6 +32,8 @@ import GHC.Types.Unique
 import GHC.Types.Unique.DFM
 
 import GHC.Utils.Outputable
+import Data.List
+import Data.Ord
 
 -- | Information about modules in the package being compiled
 data HomeModInfo = HomeModInfo
@@ -93,6 +97,9 @@ delFromHpt = delFromUDFM
 addToHpt :: HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
 addToHpt = addToUDFM
 
+addHomeModInfoToHpt :: HomeModInfo -> HomePackageTable -> HomePackageTable
+addHomeModInfoToHpt hmi hpt = addToHpt hpt (moduleName (mi_module (hm_iface hmi))) hmi
+
 addListToHpt
   :: HomePackageTable -> [(ModuleName, HomeModInfo)] -> HomePackageTable
 addListToHpt = addListToUDFM
@@ -100,6 +107,14 @@ addListToHpt = addListToUDFM
 listToHpt :: [(ModuleName, HomeModInfo)] -> HomePackageTable
 listToHpt = listToUDFM
 
+listHMIToHpt :: [HomeModInfo] -> HomePackageTable
+listHMIToHpt hmis =
+  listToHpt [(moduleName (mi_module (hm_iface hmi)), hmi) | hmi <- sorted_hmis]
+  where
+    -- Sort to put Non-boot things last, so they overwrite the boot interfaces
+    -- in the HPT, other than that, the order doesn't matter
+    sorted_hmis = sortOn (Down . mi_boot . hm_iface) hmis
+
 lookupHptByModule :: HomePackageTable -> Module -> Maybe HomeModInfo
 -- The HPT is indexed by ModuleName, not Module,
 -- we must check for a hit on the right Module
diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs
index 5b5d152711..027cbef51b 100644
--- a/compiler/GHC/Unit/Module/Graph.hs
+++ b/compiler/GHC/Unit/Module/Graph.hs
@@ -21,7 +21,7 @@ module GHC.Unit.Module.Graph
    , needsTemplateHaskellOrQQ
    , isTemplateHaskellOrQQNonBoot
    , showModMsg
-   )
+   , moduleGraphNodeModule)
 where
 
 import GHC.Prelude
@@ -54,6 +54,10 @@ data ModuleGraphNode
   -- | There is a module summary node for each module, signature, and boot module being built.
   | ModuleNode ExtendedModSummary
 
+moduleGraphNodeModule :: ModuleGraphNode -> Maybe ExtendedModSummary
+moduleGraphNodeModule (InstantiationNode {}) = Nothing
+moduleGraphNodeModule (ModuleNode ems)    = Just ems
+
 instance Outputable ModuleGraphNode where
   ppr = \case
     InstantiationNode iuid -> ppr iuid
diff --git a/compiler/GHC/Unit/Module/ModSummary.hs b/compiler/GHC/Unit/Module/ModSummary.hs
index d36636e340..ba59655033 100644
--- a/compiler/GHC/Unit/Module/ModSummary.hs
+++ b/compiler/GHC/Unit/Module/ModSummary.hs
@@ -11,7 +11,6 @@ module GHC.Unit.Module.ModSummary
    , ms_mod_name
    , ms_imps
    , ms_mnwib
-   , ms_home_allimps
    , ms_home_srcimps
    , ms_home_imps
    , msHiFilePath
@@ -128,9 +127,6 @@ home_imps imps = [ lmodname |  (mb_pkg, lmodname) <- imps,
         isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special
         isLocal _ = False
 
-ms_home_allimps :: ModSummary -> [ModuleName]
-ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms)
-
 -- | Like 'ms_home_imps', but for SOURCE imports.
 ms_home_srcimps :: ModSummary -> [Located ModuleName]
 ms_home_srcimps = home_imps . ms_srcimps
diff --git a/compiler/GHC/Unit/Types.hs-boot b/compiler/GHC/Unit/Types.hs-boot
index f8ad571935..fa4dde3feb 100644
--- a/compiler/GHC/Unit/Types.hs-boot
+++ b/compiler/GHC/Unit/Types.hs-boot
@@ -1,13 +1,15 @@
+{-# LANGUAGE KindSignatures #-}
 module GHC.Unit.Types where
 
 import GHC.Prelude ()
 import {-# SOURCE #-} GHC.Utils.Outputable
-import {-# SOURCE #-} GHC.Unit.Module.Name
+import {-# SOURCE #-} GHC.Unit.Module.Name ( ModuleName )
+import Data.Kind (Type)
 
 data UnitId
-data GenModule unit
-data GenUnit uid
-data Indefinite unit
+data GenModule (unit :: Type)
+data GenUnit (uid :: Type)
+data Indefinite (unit :: Type)
 
 type Module      = GenModule  Unit
 type Unit        = GenUnit    UnitId