[Git][ghc/ghc][wip/torsten.schmits/parallel-depanal-downsweep] use wrapAction as well

[Torsten Schmits (@torsten.schmits)]

Torsten Schmits pushed to branch wip/torsten.schmits/parallel-depanal-downsweep at Glasgow Haskell Compiler / GHC


Commits:
f037eaf8 by Torsten Schmits at 2024-05-16T17:34:29+02:00
use wrapAction as well

- - - - -


1 changed file:

- compiler/GHC/Driver/Make.hs


Changes:

=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -111,7 +111,6 @@ import GHC.Unit.Module.ModDetails
 import Data.Either ( rights, partitionEithers, lefts )
 import qualified Data.Map as Map
 import qualified Data.Set as Set
-import Data.Traversable (for)
 
 import Control.Concurrent ( newQSem, waitQSem, signalQSem, ThreadId, killThread, forkIOWithUnmask )
 import qualified GHC.Conc as CC
@@ -1775,12 +1774,12 @@ rootSummariesParallel ::
   (HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)) ->
   [Target] ->
   IO ([(UnitId, DriverMessages)], [ModSummary])
-rootSummariesParallel n_jobs hsc_env getRootSummary targets = do
+rootSummariesParallel n_jobs hsc_env get_summary targets = do
   n_cap <- getNumCapabilities
   let bundle_size = max 1 (length targets `div` (n_cap * 2))
       bundles = mk_bundles bundle_size targets
   (actions, results) <- unzip <$> mapM action_and_result (zip [1..] bundles)
-  runPipelines n_jobs hsc_env mkUnknownDiagnostic messager actions
+  runPipelines n_jobs hsc_env mkUnknownDiagnostic Nothing actions
   partitionEithers . concat . catMaybes <$!> sequence results
   where
     mk_bundles sz = unfoldr \case
@@ -1791,12 +1790,13 @@ rootSummariesParallel n_jobs hsc_env getRootSummary targets = do
       res_var <- liftIO newEmptyMVar
       pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var)
 
-    action log_queue_id ts = do
-      env at MakeEnv {compile_sem} <- ask
-      lift $ lift $ withAbstractSem compile_sem do
-        withLoggerHsc log_queue_id env (for ts . getRootSummary)
-
-    messager = Just (mkBatchMsg hsc_env)
+    action log_queue_id target_bundle = do
+      env at MakeEnv {diag_wrapper, compile_sem} <- ask
+      lift $ MaybeT $
+        withAbstractSem compile_sem $
+        withLoggerHsc log_queue_id env \ lcl_hsc_env ->
+          wrapAction diag_wrapper lcl_hsc_env $
+          mapM (get_summary lcl_hsc_env) target_bundle
 
 -- | This function checks then important property that if both p and q are home units
 -- then any dependency of p, which transitively depends on q is also a home unit.
@@ -2721,7 +2721,7 @@ R.hs:        module R where
 == Why we need to rehydrate A's ModIface before compiling R.hs
 
 After compiling A.hs we'll have a TypeEnv in which the Id for `f` has a type
-type uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same
+that uses the AbstractTyCon T; and a TyCon for `S` that also mentions that same
 AbstractTyCon. (Abstract because it came from R.hs-boot; we know nothing about
 it.)
 



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f037eaf84d4fa1f227f85ef45f75ab609554fd6f
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/20240516/a7b1cc19/attachment-0001.html>