[Git][ghc/ghc][wip/torsten.schmits/parallel-depanal-downsweep] use thread-safe loggers

Torsten Schmits (@torsten.schmits) gitlab at gitlab.haskell.org
Thu May 16 12:02:52 UTC 2024



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


Commits:
f05c1ca6 by Torsten Schmits at 2024-05-16T14:02:38+02:00
use thread-safe loggers

- - - - -


1 changed file:

- compiler/GHC/Driver/Make.hs


Changes:

=====================================
compiler/GHC/Driver/Make.hs
=====================================
@@ -6,6 +6,7 @@
 {-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE BlockArguments #-}
 
 -- -----------------------------------------------------------------------------
 --
@@ -110,6 +111,7 @@ 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
@@ -1566,7 +1568,9 @@ downsweep :: WorkerLimit
                 -- which case there can be repeats
 downsweep n_jobs hsc_env old_summaries excl_mods allow_dup_roots
    = do
-       (root_errs, rootSummariesOk) <- rootSummariesPar n_jobs hsc_env getRootSummary roots
+       (root_errs, rootSummariesOk) <-
+         rootSummariesParallel n_jobs hsc_env
+         (getRootSummary excl_mods old_summary_map) roots
        let root_map = mkRootMap rootSummariesOk
        checkDuplicates root_map
        (deps, map0) <- loopSummaries rootSummariesOk (M.empty, root_map)
@@ -1616,37 +1620,6 @@ downsweep n_jobs hsc_env old_summaries excl_mods allow_dup_roots
         old_summary_map :: M.Map (UnitId, FilePath) ModSummary
         old_summary_map = M.fromList [((ms_unitid ms, msHsFilePath ms), ms) | ms <- old_summaries]
 
-        getRootSummary :: Target -> IO (Either (UnitId, DriverMessages) ModSummary)
-        getRootSummary Target { targetId = TargetFile file mb_phase
-                              , targetContents = maybe_buf
-                              , targetUnitId = uid
-                              }
-           = do let offset_file = augmentByWorkingDirectory dflags file
-                exists <- liftIO $ doesFileExist offset_file
-                if exists || isJust maybe_buf
-                    then first (uid,) <$>
-                        summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
-                                       maybe_buf
-                    else return $ Left $ (uid,) $ singleMessage
-                                $ mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
-            where
-              dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
-              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
-        getRootSummary Target { targetId = TargetModule modl
-                              , targetContents = maybe_buf
-                              , targetUnitId = uid
-                              }
-           = do maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot
-                                           (L rootLoc modl) (ThisPkg (homeUnitId home_unit))
-                                           maybe_buf excl_mods
-                case maybe_summary of
-                   FoundHome s  -> return (Right s)
-                   FoundHomeWithError err -> return (Left err)
-                   _ -> return $ Left $ (uid, moduleNotFoundErr modl)
-            where
-              home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
-        rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
-
         -- In a root module, the filename is allowed to diverge from the module
         -- name, so we have to check that there aren't multiple root files
         -- defining the same module (otherwise the duplicates will be silently
@@ -1738,40 +1711,84 @@ downsweep n_jobs hsc_env old_summaries excl_mods allow_dup_roots
             GWIB { gwib_mod = L loc mod, gwib_isBoot = is_boot } = gwib
             wanted_mod = L loc mod
 
+getRootSummary ::
+  [ModuleName] ->
+  M.Map (UnitId, FilePath) ModSummary ->
+  HscEnv ->
+  Target ->
+  IO (Either (UnitId, DriverMessages) ModSummary)
+getRootSummary excl_mods old_summary_map hsc_env target
+  | TargetFile file mb_phase <- targetId
+  = do
+    let offset_file = augmentByWorkingDirectory dflags file
+    exists <- liftIO $ doesFileExist offset_file
+    if exists || isJust maybe_buf
+    then first (uid,) <$>
+         summariseFile hsc_env home_unit old_summary_map offset_file mb_phase
+         maybe_buf
+    else
+      return $ Left $ (uid,) $ singleMessage $
+      mkPlainErrorMsgEnvelope noSrcSpan (DriverFileNotFound offset_file)
+  | TargetModule modl <- targetId
+  = do
+    maybe_summary <- summariseModule hsc_env home_unit old_summary_map NotBoot
+                     (L rootLoc modl) (ThisPkg (homeUnitId home_unit))
+                     maybe_buf excl_mods
+    pure case maybe_summary of
+      FoundHome s  -> Right s
+      FoundHomeWithError err -> Left err
+      _ -> Left (uid, moduleNotFoundErr modl)
+    where
+      Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target
+      home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
+      rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
+      dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
+
 -- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline
 -- system.
--- Create 'MakeAction's for each 'Target' that uses 'withAbstractSem' to wait
--- for a free slot, limiting the number of concurrently computed summaries to
--- the value of the @-j@ option or the slots allocated by the job server, if
--- that is used.
+-- Create bundles of 'MakeAction's for each 'Target' that uses 'withAbstractSem'
+-- to wait for a free slot, limiting the number of concurrently computed
+-- summaries to the value of the @-j@ option or the slots allocated by the job
+-- server, if that is used.
+--
+-- The bundle size for @n@ targets on a machine with @c@ capabilites (threads)
+-- is computed as @n / (2 c)@.
+-- This is a best guess based on benchmarking some synthetic sets of modules
+-- with @ghc -M at .
+-- If you can come up with a more rigorously determined optimum, feel free to
+-- change it!
 --
 -- The 'MakeAction' returns 'Maybe', which is not handled as an error, because
 -- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the
 -- result won't be read anyway here.
-rootSummariesPar ::
+rootSummariesParallel ::
   WorkerLimit ->
   HscEnv ->
-  (Target -> IO (Either (UnitId, DriverMessages) ModSummary)) ->
+  (HscEnv -> Target -> IO (Either (UnitId, DriverMessages) ModSummary)) ->
   [Target] ->
   IO ([(UnitId, DriverMessages)], [ModSummary])
-rootSummariesPar n_jobs hsc_env getRootSummary targets = do
+rootSummariesParallel n_jobs hsc_env getRootSummary targets = do
   n_cap <- getNumCapabilities
   let bundle_size = max 1 (length targets `div` (n_cap * 2))
-  (actions, results) <- unzip <$> mapM mk_action (bundles bundle_size targets)
-  runPipelines n_jobs hsc_env mkUnknownDiagnostic (Just (mkBatchMsg hsc_env)) actions
-  partitionEithers . concat . catMaybes <$> sequence results
+      bundles = mk_bundles bundle_size targets
+  (actions, results) <- unzip <$> mapM action_and_result (zip [1..] bundles)
+  runPipelines n_jobs hsc_env mkUnknownDiagnostic messager actions
+  partitionEithers . concat . catMaybes <$!> sequence results
   where
-    bundles sz = unfoldr $ \case
+    mk_bundles sz = unfoldr \case
       [] -> Nothing
       ts -> Just (splitAt sz ts)
 
-    mk_action ts = do
+    action_and_result (log_queue_id, ts) = do
       res_var <- liftIO newEmptyMVar
-      let
-        action = do
-          MakeEnv {compile_sem} <- ask
-          lift $ lift $ withAbstractSem compile_sem (mapM getRootSummary ts)
-      pure (MakeAction action res_var, readMVar res_var)
+      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)
 
 -- | 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.



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

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


More information about the ghc-commits mailing list