[Git][ghc/ghc][wip/24107] driver: Ensure we force the lookup of old build artifacts before returning the build plan

[Zubin (@wz1000)]

Zubin pushed to branch wip/24107 at Glasgow Haskell Compiler / GHC


Commits:
cb55e42f by Zubin Duggal at 2023-12-01T12:35:17+05:30
driver: Ensure we force the lookup of old build artifacts before returning the build plan

This prevents us from retaining all previous build artifacts in memory until a
recompile finishes, instead only retaining the exact artifacts we need.

Fixes #24118

- - - - -


1 changed file:

- compiler/GHC/Driver/Make.hs


Changes:

=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -1145,33 +1145,37 @@ interpretBuildPlan hug mhmi_cache old_hpt plan = do
           -- which would retain all the result variables, preventing us from collecting them
           -- after they are no longer used.
           !build_deps = getDependencies direct_deps build_map
-      let build_action =
-            withCurrentUnit (moduleGraphNodeUnitId mod) $ do
-            (hug, deps) <- wait_deps_hug hug_var build_deps
+      let !build_action =
             case mod of
               InstantiationNode uid iu -> do
-                executeInstantiationNode mod_idx n_mods hug uid iu
-                return (Nothing, deps)
-              ModuleNode _build_deps ms -> do
+                withCurrentUnit (moduleGraphNodeUnitId mod) $ do
+                  (hug, deps) <- wait_deps_hug hug_var build_deps
+                  executeInstantiationNode mod_idx n_mods hug uid iu
+                  return (Nothing, deps)
+              ModuleNode _build_deps ms ->
                 let !old_hmi = M.lookup (msKey ms) old_hpt
                     rehydrate_mods = mapMaybe nodeKeyModName <$> rehydrate_nodes
-                hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms
-                -- Write the HMI to an external cache (if one exists)
-                -- See Note [Caching HomeModInfo]
-                liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi
-                -- 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_ hug_var (return . addHomeModInfoToHug hmi)
-                return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps )
+                in withCurrentUnit (moduleGraphNodeUnitId mod) $ do
+                     (hug, deps) <- wait_deps_hug hug_var build_deps
+                     hmi <- executeCompileNode mod_idx n_mods old_hmi hug rehydrate_mods ms
+                     -- Write the HMI to an external cache (if one exists)
+                     -- See Note [Caching HomeModInfo]
+                     liftIO $ forM mhmi_cache $ \hmi_cache -> addHmiToCache hmi_cache hmi
+                     -- 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_ hug_var (return . addHomeModInfoToHug hmi)
+                     return (Just hmi, addToModuleNameSet (moduleGraphNodeUnitId mod) (ms_mod_name ms) deps )
               LinkNode _nks uid -> do
-                  executeLinkNode hug (mod_idx, n_mods) uid direct_deps
-                  return (Nothing, deps)
+                  withCurrentUnit (moduleGraphNodeUnitId mod) $ do
+                    (hug, deps) <- wait_deps_hug hug_var build_deps
+                    executeLinkNode hug (mod_idx, n_mods) uid direct_deps
+                    return (Nothing, deps)
 
 
       res_var <- liftIO newEmptyMVar
       let result_var = mkResultVar res_var
       setModulePipeline (mkNodeKey mod) (mkBuildResult origin result_var)
-      return $ (MakeAction build_action res_var)
+      return $! (MakeAction build_action res_var)
 
 
     buildOneLoopyModule :: ModuleGraphNodeWithBootFile -> BuildM [MakeAction]
@@ -2986,7 +2990,7 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do
       run_pipeline :: RunMakeM a -> IO (Maybe a)
       run_pipeline p = runMaybeT (runReaderT p env)
 
-data MakeAction = forall a . MakeAction (RunMakeM a) (MVar (Maybe a))
+data MakeAction = forall a . MakeAction !(RunMakeM a) !(MVar (Maybe a))
 
 waitMakeAction :: MakeAction -> IO ()
 waitMakeAction (MakeAction _ mvar) = () <$ readMVar mvar



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb55e42f7808a87d83828523b0d5c7c97e3cd00b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cb55e42f7808a87d83828523b0d5c7c97e3cd00b
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20231201/20634637/attachment-0001.html>