Rodrigo Mesquita pushed to branch wip/romes/27514 at Glasgow Haskell Compiler / GHC

Commits:

1 changed file:

Changes:

  • compiler/GHC/Driver/Downsweep.hs
    ... ... @@ -114,6 +114,9 @@ import Control.Monad.Trans.Class
    114 114 
     import System.IO.Unsafe (unsafeInterleaveIO)
    115 115 
     import Data.IORef
    116 116 
     import qualified Data.List.NonEmpty as NE
    117 
    +import Control.Concurrent
    118 
    +import Control.Concurrent.STM.TQueue
    119 
    +import Control.Concurrent.STM
    117 120
    118 121 
     {-
    119 122 
     Note [The ModuleGraph]
    ... ... @@ -258,36 +261,46 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
    258 261 
       n_jobs     <- mkWorkerLimit (hsc_dflags hsc_env)
    259 262 
       summ_cache <- newIORef (mkModSummaryCache (zip old_summaries (repeat SummOld)))
    260 263 
       imps_cache <- newIORef Map.empty
    261 
    -  (root_errs, root_summaries) <- rootSummariesParallel n_jobs hsc_env diag_wrapper msg
    262 
    -                                   (getRootSummary excl_mods summ_cache imps_cache)
    263 
    -  let closure_errs = checkHomeUnitsClosed unit_env
    264 
    -      unit_env = hsc_unit_env hsc_env
    265 
    -
    266 
    -      all_errs = closure_errs ++ root_errs
    267 
    -
    268 
    -  case all_errs of
    269 
    -    [] -> do
    270 
    -       (downsweep_errs, downsweep_nodes) <-
    271 
    -          downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph
    272 
    -            excl_mods allow_dup_roots DownsweepUseCompile (map ModuleNodeCompile root_summaries) []
    273 
    -
    274 
    -       let (other_errs, unit_nodes) = partitionEithers $
    275 
    -              HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) []
    276 
    -                                      (hsc_HUG hsc_env)
    277 
    -
    278 
    -       let all_nodes = downsweep_nodes ++ unit_nodes
    279 
    -       let all_errs = downsweep_errs ++ other_errs
    280 
    -
    281 
    -       let logger = hsc_logger hsc_env
    282 
    -           tmpfs = hsc_tmpfs hsc_env
    283 
    -       -- if we have been passed -fno-code, we enable code generation
    284 
    -       -- for dependencies of modules that have -XTemplateHaskell,
    285 
    -       -- otherwise those modules will fail to compile.
    286 
    -       -- See Note [-fno-code mode] #8025
    287 
    -       th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes
    288 
    -
    289 
    -       return (all_errs, th_configured_nodes)
    290 
    -    _  -> return (all_errs, emptyMG)
    264 
    +  withMakeEnv n_jobs hsc_env diag_wrapper msg $ \make_env -> do
    265 
    +    (root_errs, root_summaries) <- rootSummariesParallel n_jobs make_env (hsc_targets hsc_env)
    266 
    +                                     (getRootSummary excl_mods summ_cache imps_cache)
    267 
    +    let closure_errs = checkHomeUnitsClosed unit_env
    268 
    +        unit_env = hsc_unit_env hsc_env
    269 
    +
    270 
    +        all_errs = closure_errs ++ root_errs
    271 
    +
    272 
    +    case all_errs of
    273 
    +      [] -> do
    274 
    +         let env = DownsweepEnv
    275 
    +               { ds_hsc_env         = hsc_env
    276 
    +               , ds_summaries_cache = summ_cache
    277 
    +               , ds_imports_cache   = imps_cache
    278 
    +               , ds_mode            = DownsweepUseCompile
    279 
    +               , ds_excl_mods       = excl_mods
    280 
    +               , ds_n_jobs          = n_jobs
    281 
    +               , ds_make_env        = make_env
    282 
    +               }
    283 
    +         (downsweep_errs, downsweep_nodes) <- runDownsweepM env $
    284 
    +            downsweepFromRootNodes maybe_base_graph allow_dup_roots
    285 
    +              (map ModuleNodeCompile root_summaries) []
    286 
    +
    287 
    +         let (other_errs, unit_nodes) = partitionEithers $
    288 
    +                HUG.unitEnv_foldWithKey (\nodes uid hue -> nodes ++ unitModuleNodes downsweep_nodes uid hue) []
    289 
    +                                        (hsc_HUG hsc_env)
    290 
    +
    291 
    +         let all_nodes = downsweep_nodes ++ unit_nodes
    292 
    +         let all_errs = downsweep_errs ++ other_errs
    293 
    +
    294 
    +         let logger = hsc_logger hsc_env
    295 
    +             tmpfs = hsc_tmpfs hsc_env
    296 
    +         -- if we have been passed -fno-code, we enable code generation
    297 
    +         -- for dependencies of modules that have -XTemplateHaskell,
    298 
    +         -- otherwise those modules will fail to compile.
    299 
    +         -- See Note [-fno-code mode] #8025
    300 
    +         th_configured_nodes <- enableCodeGenForTH logger tmpfs unit_env all_nodes
    301 
    +
    302 
    +         return (all_errs, th_configured_nodes)
    303 
    +      _  -> return (all_errs, emptyMG)
    291 304 
       where
    292 305 
         -- Dependencies arising on a unit (backpack and module linking deps)
    293 306 
         unitModuleNodes :: [ModuleGraphNode] -> UnitId -> HomeUnitEnv -> [Either (Messages DriverMessage) ModuleGraphNode]
    ... ... @@ -330,15 +343,28 @@ downsweep hsc_env diag_wrapper msg old_summaries maybe_base_graph excl_mods allo
    330 343 
     downsweepThunk :: HscEnv -> ModSummary -> IO ModuleGraph
    331 344 
     downsweepThunk hsc_env mod_summary = unsafeInterleaveIO $ do
    332 345 
       debugTraceMsg (hsc_logger hsc_env) 3 $ text "Computing Module Graph thunk..."
    346 
    +  njobs <- mkWorkerLimit (hsc_dflags hsc_env)
    333 347 
       summs <- newIORef (mkModSummaryCache [(mod_summary,SummOld)])
    334 348 
       imps  <- newIORef mempty
    335 
    -  ~(errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed [ModuleNodeCompile mod_summary] []
    336 
    -  let dflags = hsc_dflags hsc_env
    337 
    -  liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)
    338 
    -                                   (initPrintConfig dflags)
    339 
    -                                   (initDiagOpts dflags)
    340 
    -                                   (GhcDriverMessage <$> unionManyMessages errs)
    341 
    -  return (mkModuleGraph mg)
    349 
    +  withMakeEnv njobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do
    350 
    +    let env = DownsweepEnv
    351 
    +          { ds_hsc_env         = hsc_env
    352 
    +          , ds_summaries_cache = summs
    353 
    +          , ds_imports_cache   = imps
    354 
    +          , ds_mode            = DownsweepUseFixed
    355 
    +          , ds_excl_mods       = []
    356 
    +          , ds_n_jobs          = njobs
    357 
    +          , ds_make_env        = make_env
    358 
    +          }
    359 
    +    ~(errs, mg) <- runDownsweepM env $
    360 
    +      downsweepFromRootNodes Nothing True
    361 
    +        [ModuleNodeCompile mod_summary] []
    362 
    +    let dflags = hsc_dflags hsc_env
    363 
    +    liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)
    364 
    +                                     (initPrintConfig dflags)
    365 
    +                                     (initDiagOpts dflags)
    366 
    +                                     (GhcDriverMessage <$> unionManyMessages errs)
    367 
    +    return (mkModuleGraph mg)
    342 368
    343 369 
     -- | Construct a module graph starting from the interactive context.
    344 370 
     -- Produces, a thunk, which when forced will perform the downsweep.
    ... ... @@ -362,13 +388,23 @@ downsweepInteractiveImports hsc_env ic = unsafeInterleaveIO $ do
    362 388 
       -- :load. Any home package modules need to already be in here.
    363 389 
       let cached_nodes = Map.fromList [ (mkNodeKey n, NSuccess n) | n <- mg_mss (hsc_mod_graph hsc_env) ]
    364 390
    391 
    +  n_jobs     <- mkWorkerLimit (hsc_dflags hsc_env)
    365 392 
       summ_cache <- newIORef mempty
    366 393 
       imps_cache <- newIORef mempty
    367 
    -  let env = DownsweepEnv hsc_env DownsweepUseFixed{-or DownsweepUseCompile?-} summ_cache imps_cache []
    368 
    -  graph <- runDownsweepM env do
    369 
    -    loopFromInteractive cached_nodes interactive_mn imps
    370 
    -  let all_nodes  = [s | NSuccess s <- M.elems graph ]
    371 
    -  return $ mkModuleGraph all_nodes
    394 
    +  withMakeEnv n_jobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do
    395 
    +    let env = DownsweepEnv
    396 
    +          { ds_hsc_env         = hsc_env
    397 
    +          , ds_mode            = DownsweepUseFixed{-or DownsweepUseCompile?-}
    398 
    +          , ds_summaries_cache = summ_cache
    399 
    +          , ds_imports_cache   = imps_cache
    400 
    +          , ds_excl_mods       = []
    401 
    +          , ds_n_jobs          = n_jobs
    402 
    +          , ds_make_env        = make_env
    403 
    +          }
    404 
    +    graph <- runDownsweepM env do
    405 
    +      loopFromInteractive cached_nodes interactive_mn imps
    406 
    +    let all_nodes  = [s | NSuccess s <- M.elems graph ]
    407 
    +    return $ mkModuleGraph all_nodes
    372 408
    373 409 
     -- | Create a module graph from a list of installed modules.
    374 410 
     -- This is used by the loader when we need to load modules but there
    ... ... @@ -396,19 +432,31 @@ downsweepInstalledModules hsc_env mods = do
    396 432 
                 -- already know that we can find the modules we need to load.
    397 433 
                 _ -> throwGhcException $ ProgramError $ showSDoc (hsc_dflags hsc_env) $ text "downsweepInstalledModules: Could not find installed module" <+> ppr i
    398 434
    435 
    +    njobs <- mkWorkerLimit (hsc_dflags hsc_env)
    399 436 
         nodes <- mapM process installed_mods
    400 437 
         summs <- newIORef mempty
    401 438 
         imps  <- newIORef mempty
    402 
    -    (errs, mg) <- downsweepFromRootNodes hsc_env summs imps Nothing [] True DownsweepUseFixed nodes external_uids
    439 
    +    withMakeEnv njobs hsc_env mkUnknownDiagnostic Nothing $ \make_env -> do
    440 
    +      let env = DownsweepEnv
    441 
    +            { ds_hsc_env         = hsc_env
    442 
    +            , ds_summaries_cache = summs
    443 
    +            , ds_imports_cache   = imps
    444 
    +            , ds_mode            = DownsweepUseFixed
    445 
    +            , ds_excl_mods       = []
    446 
    +            , ds_n_jobs          = njobs
    447 
    +            , ds_make_env        = make_env
    448 
    +            }
    449 
    +      (errs, mg) <- runDownsweepM env $
    450 
    +        downsweepFromRootNodes Nothing True nodes external_uids
    403 451
    404 
    -    -- Similarly here, we should really not get any errors, but print them out if we do.
    405 
    -    let dflags = hsc_dflags hsc_env
    406 
    -    liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)
    407 
    -                                     (initPrintConfig dflags)
    408 
    -                                     (initDiagOpts dflags)
    409 
    -                                     (GhcDriverMessage <$> unionManyMessages errs)
    452 
    +      -- Similarly here, we should really not get any errors, but print them out if we do.
    453 
    +      let dflags = hsc_dflags hsc_env
    454 
    +      liftIO $ printOrThrowDiagnostics (hsc_logger hsc_env)
    455 
    +                                       (initPrintConfig dflags)
    456 
    +                                       (initDiagOpts dflags)
    457 
    +                                       (GhcDriverMessage <$> unionManyMessages errs)
    410 458
    411 
    -    return (mkModuleGraph mg)
    459 
    +      return (mkModuleGraph mg)
    412 460
    413 461 
     -----------------------------------------------------------------------------
    414 462 
     -- * Orchestrator: downsweepFromRootNodes
    ... ... @@ -450,30 +498,26 @@ data DownsweepMode = DownsweepUseCompile | DownsweepUseFixed
    450 498 
     -- 'UnitId's.
    451 499 
     -- This function will start at the given roots, and traverse downwards to find
    452 500 
     -- all the dependencies, all the way to the leaf units.
    453 
    -downsweepFromRootNodes :: HscEnv
    454 
    -                  -> ModSummaryCache
    455 
    -                  -> ImportsCache
    456 
    -                  -> Maybe ModuleGraph
    457 
    -                  -> [ModuleName]
    458 
    -                  -> Bool
    459 
    -                  -> DownsweepMode -- ^ Whether to create fixed or compile nodes for dependencies
    460 
    -                  -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo
    461 
    -                  -> [UnitId] -- ^ The starting units
    462 
    -                  -> IO ([DriverMessages], [ModuleGraphNode])
    463 
    -downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods allow_dup_roots mode root_nodes root_uids = do
    501 
    +downsweepFromRootNodes
    502 
    +  :: Maybe ModuleGraph
    503 
    +  -> Bool
    504 
    +  -> [ModuleNodeInfo] -- ^ The starting ModuleNodeInfo
    505 
    +  -> [UnitId] -- ^ The starting units
    506 
    +  -> DownsweepM ([DriverMessages], [ModuleGraphNode])
    507 
    +downsweepFromRootNodes maybe_base_graph allow_dup_roots root_nodes root_uids =
    508 
    +  ReaderT $ \env@DownsweepEnv{..} -> do
    464 509 
          when (not allow_dup_roots) $
    465 510 
            case root_duplicates of
    466 511 
              []           -> return ()
    467 
    -         (dup_root:_) -> multiRootsErr sec dup_root
    468 
    -     modifyImpsCache imps_cache (`M.union` mkRootMap root_nodes) -- add root nodes to imports cache
    469 
    -     let env = DownsweepEnv hsc_env mode summ_cache imps_cache excl_mods
    470 
    -     deps' <- runDownsweepM env  $ do
    512 
    +         (dup_root:_) -> multiRootsErr (sec ds_hsc_env) dup_root
    513 
    +     modifyImpsCache ds_imports_cache (`M.union` mkRootMap root_nodes) -- add root nodes to imports cache
    514 
    +     deps' <- runDownsweepM env $ do
    471 515 
             let base_nodes = maybe M.empty moduleGraphNodeMap maybe_base_graph
    472 516 
             module_deps <- loopModuleNodeInfos base_nodes root_nodes
    473 
    -        all_deps    <- loopUnits module_deps (hscActiveUnitId hsc_env) root_uids
    474 
    -        deps'       <- loopInstantiations all_deps (getHomeUnitInstantiations hsc_env)
    517 
    +        all_deps    <- loopUnits module_deps (hscActiveUnitId ds_hsc_env) root_uids
    518 
    +        deps'       <- loopInstantiations all_deps (getHomeUnitInstantiations ds_hsc_env)
    475 519 
             return deps'
    476 
    -     f_cache <- readIORef summ_cache
    520 
    +     f_cache <- readIORef ds_summaries_cache
    477 521 
          let downsweep_errs = lefts (M.elems f_cache)
    478 522 
              downsweep_nodes = [ s | NSuccess s <- M.elems deps' ]
    479 523
    ... ... @@ -501,7 +545,7 @@ downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods
    501 545 
         moduleGraphNodeMap graph
    502 546 
             = M.fromList [(mkNodeKey node, NSuccess node) | node <- mgModSummaries' graph]
    503 547
    504 
    -    sec = initSourceErrorContext (hsc_dflags hsc_env)
    548 
    +    sec hsc_env = initSourceErrorContext (hsc_dflags hsc_env)
    505 549
    506 550 
     --------------------------------------------------------------------------------
    507 551 
     -- ** 'DownsweepM'
    ... ... @@ -509,11 +553,14 @@ downsweepFromRootNodes hsc_env summ_cache imps_cache maybe_base_graph excl_mods
    509 553
    510 554 
     type DownsweepM a = ReaderT DownsweepEnv IO a
    511 555 
     data DownsweepEnv = DownsweepEnv {
    512 
    -      downsweep_hsc_env :: HscEnv
    513 
    -    , _downsweep_mode :: DownsweepMode
    514 
    -    , _downsweep_summaries_cache :: ModSummaryCache
    515 
    -    , downsweep_imports_cache :: ImportsCache
    516 
    -    , _downsweep_excl_mods :: [ModuleName]
    556 
    +      ds_hsc_env         :: HscEnv
    557 
    +    , ds_mode            :: DownsweepMode
    558 
    +      -- ^ Whether to create fixed or compile nodes for dependencies
    559 
    +    , ds_summaries_cache :: ModSummaryCache
    560 
    +    , ds_imports_cache   :: ImportsCache
    561 
    +    , ds_excl_mods       :: [ModuleName]
    562 
    +    , ds_n_jobs          :: WorkerLimit
    563 
    +    , ds_make_env        :: MakeEnv
    517 564 
     }
    518 565
    519 566 
     mkModSummaryCache :: [(ModSummary, SummProvenance)] -> ModSummaryCacheMap
    ... ... @@ -553,7 +600,7 @@ loopModuleNodeInfos :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [ModuleNodeInf
    553 600 
     loopUnits           :: M.Map NodeKey (NodeRes ModuleGraphNode) -> UnitId -> [UnitId]            -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
    554 601 
     loopInstantiations  :: M.Map NodeKey (NodeRes ModuleGraphNode) -> [(UnitId, InstantiatedUnit)]  -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
    555 602 
     loopFromInteractive :: M.Map NodeKey (NodeRes ModuleGraphNode) -> Module -> [InteractiveImport] -> DownsweepM (M.Map NodeKey (NodeRes ModuleGraphNode))
    556 
    -loopDownsweepNodes  base_map nodes = dfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand
    603 
    +loopDownsweepNodes  base_map nodes = parDfsBuild (Just base_map) nodes dsNodeInfoKey dsNodeExpand
    557 604 
     loopModuleNodeInfos base_map       = loopDownsweepNodes base_map . map DSMod
    558 605 
     loopUnits           base_map homud = loopDownsweepNodes base_map . map (DSUnit homud)
    559 606 
     loopInstantiations  base_map       = loopDownsweepNodes base_map . map (uncurry DSInst)
    ... ... @@ -617,7 +664,7 @@ dsNodeExpand = \case
    617 664
    618 665 
     expandModuleSummary :: ModSummary -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
    619 666 
     expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do that.
    620 
    -    hsc_env <- asks downsweep_hsc_env
    667 
    +    hsc_env <- asks ds_hsc_env
    621 668 
         let home_uid  = ms_unitid ms
    622 669 
             home_unit = ue_unitHomeUnit home_uid (hsc_unit_env hsc_env)
    623 670 
         (final_deps, todo) <- unzip <$> mapM (expandModImport home_uid home_unit) (calcDeps ms)
    ... ... @@ -673,7 +720,7 @@ expandModuleSummary ms = do -- Didn't work out what the imports mean yet, now do
    673 720 
     -- NB: If you ever reach a Fixed node, everything under that also must be fixed.
    674 721 
     expandFixedModuleNode :: ModNodeKeyWithUid -> ModLocation -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
    675 722 
     expandFixedModuleNode key loc = do
    676 
    -    hsc_env <- asks downsweep_hsc_env
    723 
    +    hsc_env <- asks ds_hsc_env
    677 724 
         -- MP: TODO, we should just read the dependency info from the interface rather than either
    678 725 
         -- a. Loading the whole thing into the EPS (this might never nececssary and causes lots of things to be permanently loaded into memory)
    679 726 
         -- b. Loading the whole interface into a buffer before discarding it. (wasted allocation and deserialisation)
    ... ... @@ -732,7 +779,7 @@ expandUnitNode :: UnitId {-^ @node_uid@ -} -> UnitId {-^ Home unit from where @n
    732 779 
     expandUnitNode node_uid home_context_uid = do
    733 780 
         -- Set active unit so that looking loopUnit finds the correct
    734 781 
         -- -package flags in the unit state.
    735 
    -    hsc_env <- asks downsweep_hsc_env
    782 
    +    hsc_env <- asks ds_hsc_env
    736 783 
         let lcl_hsc_env = hscSetActiveUnitId home_context_uid hsc_env
    737 784 
         case unitDepends <$> lookupUnitId (hsc_units lcl_hsc_env) node_uid of
    738 785 
           Just us -> pure $ NSuccess ((UnitNode us node_uid), map (\u -> DSUnit{node_uid=u, home_context_uid{-inherit-}}) us)
    ... ... @@ -745,8 +792,8 @@ expandInstantiatedUnit iud home_uid = pure $ NSuccess
    745 792
    746 793 
     expandInteractiveImports :: Module -> [InteractiveImport] -> DownsweepM (NodeRes (ModuleGraphNode, [DownsweepNode]))
    747 794 
     expandInteractiveImports imod imps = do
    748 
    -  hsc_env    <- asks downsweep_hsc_env
    749 
    -  imps_cache <- asks downsweep_imports_cache
    795 
    +  hsc_env    <- asks ds_hsc_env
    796 
    +  imps_cache <- asks ds_imports_cache
    750 797
    751 798 
       let
    752 799 
         -- A simple edge to a module from the same home unit
    ... ... @@ -807,13 +854,13 @@ downsweepSummarise :: HomeUnit
    807 854 
                        -> Maybe (StringBuffer, UTCTime)
    808 855 
                        -> DownsweepM SummariseResult
    809 856 
     downsweepSummarise home_unit imp maybe_buf = do
    810 
    -  DownsweepEnv hsc_env mode summaries_cache_ref imports_cache_ref excl_mods <- ask
    811 
    -  liftIO $ case mode of
    857 
    +  DownsweepEnv{..} <- ask
    858 
    +  liftIO $ case ds_mode of
    812 859 
         DownsweepUseCompile ->
    813 
    -      summariseModule hsc_env home_unit summaries_cache_ref imports_cache_ref
    814 
    -                      imp maybe_buf excl_mods
    860 
    +      summariseModule ds_hsc_env home_unit ds_summaries_cache ds_imports_cache
    861 
    +                      imp maybe_buf ds_excl_mods
    815 862 
         DownsweepUseFixed ->
    816 
    -      summariseModuleInterface hsc_env home_unit imports_cache_ref imp excl_mods
    863 
    +      summariseModuleInterface ds_hsc_env home_unit ds_imports_cache imp ds_excl_mods
    817 864
    818 865 
     multiRootsErr :: SourceErrorContext -> NE.NonEmpty ModuleNodeInfo -> IO ()
    819 866 
     multiRootsErr sec (summ1 NE.:| summs)
    ... ... @@ -878,56 +925,15 @@ getRootSummary excl_mods summ_cache imports_cache hsc_env target
    878 925 
           rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
    879 926 
           dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
    880 927
    881 
    --- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline
    882 
    --- system.
    883 
    --- Create bundles of 'Target's wrapped in a 'MakeAction' that uses
    884 
    --- 'withAbstractSem' to wait for a free slot, limiting the number of
    885 
    --- concurrently computed summaries to the value of the @-j@ option or the slots
    886 
    --- allocated by the job server, if that is used.
    887 
    ---
    888 
    --- The 'MakeAction' returns 'Maybe', which is not handled as an error, because
    889 
    --- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the
    890 
    --- result won't be read anyway here.
    891 
    ---
    892 
    --- To emulate the current behavior, we funnel exceptions past the concurrency
    893 
    --- barrier and rethrow the first one afterwards.
    894 
    -rootSummariesParallel ::
    895 
    -  WorkerLimit ->
    896 
    -  HscEnv ->
    897 
    -  (GhcMessage -> AnyGhcDiagnostic) ->
    898 
    -  Maybe Messager ->
    899 
    -  (HscEnv -> Target -> IO (Either DriverMessages ModSummary)) ->
    900 
    -  IO ([DriverMessages], [ModSummary])
    901 
    -rootSummariesParallel n_jobs hsc_env diag_wrapper msg get_summary = do
    902 
    -  (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles)
    903 
    -  runPipelines n_jobs hsc_env diag_wrapper msg actions
    904 
    -  (sequence . catMaybes <$> sequence get_results) >>= \case
    905 
    -    Right results -> pure (partitionEithers (concat results))
    906 
    -    Left exc -> throwIO exc
    907 
    -  where
    908 
    -    bundles = mk_bundles targets
    909 
    -
    910 
    -    mk_bundles = unfoldr \case
    911 
    -      [] -> Nothing
    912 
    -      ts -> Just (splitAt bundle_size ts)
    913 
    -
    914 
    -    bundle_size = 20
    915 
    -
    916 
    -    targets = hsc_targets hsc_env
    917 
    -
    918 
    -    action_and_result (log_queue_id, ts) = do
    919 
    -      res_var <- liftIO newEmptyMVar
    920 
    -      pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var)
    921 
    -
    922 
    -    action log_queue_id target_bundle = do
    923 
    -      env@MakeEnv {compile_sem} <- ask
    924 
    -      lift $ lift $
    925 
    -        withAbstractSem compile_sem $
    926 
    -        withLoggerHsc log_queue_id env \ lcl_hsc_env ->
    927 
    -          MC.try (mapM (get_summary lcl_hsc_env) target_bundle) >>= \case
    928 
    -            Left e | Just (_ :: SomeAsyncException) <- fromException e ->
    929 
    -              throwIO e
    930 
    -            a -> pure a
    928 
    +-- | Execute 'getRootSummary' for the 'Target's using the parallelism pipeline system.
    929 
    +rootSummariesParallel
    930 
    +  :: WorkerLimit -> MakeEnv -> [Target]
    931 
    +  -> (HscEnv -> Target -> IO (Either DriverMessages ModSummary))
    932 
    +  -> IO ([DriverMessages], [ModSummary])
    933 
    +rootSummariesParallel n_jobs make_env targets get_summary = do
    934 
    +  partitionEithers <$> mapConcDS n_jobs bundle_size make_env get_summary targets
    935 
    +    where
    936 
    +      bundle_size = 20
    931 937
    932 938 
     --------------------------------------------------------------------------------
    933 939 
     -- * Check/validate properties and error out
    ... ... @@ -1738,7 +1744,7 @@ data NodeRes v
    1738 1744 
       -- abort.
    1739 1745 
       | NSkip
    1740 1746
    1741 
    --- | In a depth-first order, and starting from the given roots, traverse a
    1747 
    +-- | In a parallel depth-first order, and starting from the given roots, traverse a
    1742 1748 
     -- graph by iteratively expanding a node into a payload and a list of children
    1743 1749 
     -- nodes to visit next.
    1744 1750 
     --
    ... ... @@ -1762,7 +1768,7 @@ data NodeRes v
    1762 1768 
     -- Example usage: @n@ is instanced to @DownsweepNode@, @k@ is @NodeKey@, and @v@ is @ModuleNodeEdge@.
    1763 1769 
     --
    1764 1770 
     -- See also Note [Downsweep Control Flow and Caching]
    1765 
    -dfsBuild :: (Ord k, Monad m)
    1771 
    +parDfsBuild :: Ord k
    1766 1772 
              => Maybe (Map.Map k (NodeRes v))
    1767 1773 
              -- ^ Base map, existing results. We won't re-expand any of the nodes
    1768 1774 
              -- already present in this map.
    ... ... @@ -1770,29 +1776,61 @@ dfsBuild :: (Ord k, Monad m)
    1770 1776 
              -- ^ The root nodes from where to start traversal
    1771 1777 
              -> (n -> k)
    1772 1778 
              -- ^ Compute the key which uniquely identifies this node
    1773 
    -         -> (n -> m (NodeRes (v,[n])))
    1779 
    +         -> (n -> DownsweepM (NodeRes (v,[n])))
    1774 1780 
              -- ^ Expand this node into its payload result and into the list of
    1775 1781 
              -- children nodes to visit next.
    1776 
    -         -> m (Map.Map k (NodeRes v))
    1782 
    +         -> DownsweepM (Map.Map k (NodeRes v))
    1777 1783 
              -- ^ The result accumulates the payload of expanding the root nodes
    1778 1784 
              -- and all nodes transitively reachable from those roots.
    1779 
    -dfsBuild base_map roots key expand = go roots (fromMaybe Map.empty base_map)
    1785 
    +parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do
    1786 
    +    visited_var <- newTVarIO (fromMaybe Map.empty base_map)
    1787 
    +    pending     <- newTVarIO Set.empty
    1788 
    +    worklist    <- newTQueueIO
    1789 
    +    coord_tid   <- forkIO $ coordinator ds_env visited_var worklist pending -- todo: (how to) handle (async) exceptions?
    1790 
    +    mapM (atomically . writeTQueue worklist) roots
    1791 
    +    -- exit when pending and worklist are both empty *atomically*
    1792 
    +    atomically $ do
    1793 
    +      empty_worklist <- isEmptyTQueue worklist
    1794 
    +      empty_pending  <- Set.null <$> readTVar pending
    1795 
    +      unless (empty_worklist && empty_pending) $
    1796 
    +        retry
    1797 
    +    killThread coord_tid -- todo: exceptions exceptions...; maybe write "finish value", or "throwTo StopX"
    1798 
    +    readTVarIO visited_var
    1780 1799 
       where
    1781 
    -    go []     visited = pure visited
    1782 
    -    go (s:ss) visited
    1783 
    -      | k `Map.member` visited
    1784 
    -      = go ss visited
    1785 
    -      | otherwise
    1786 
    -      = do r <- expand s
    1787 
    -           case r of
    1788 
    -             NSkip ->
    1789 
    -               go ss
    1790 
    -                  (Map.insert k NSkip        visited) -- Skip!
    1791 
    -             NSuccess (v,ns) ->
    1792 
    -               go (ns ++ ss)
    1793 
    -                  (Map.insert k (NSuccess v) visited)
    1794 
    -      where
    1795 
    -        k = key s
    1800 
    +    coordinator ds_env visvar worklist pendvar = forever $ do
    1801 
    +      node <- atomically $ readTQueue worklist
    1802 
    +      let k = key node
    1803 
    +
    1804 
    +      is_done <- atomically $ do
    1805 
    +        visited <- readTVar visvar
    1806 
    +        pending <- readTVar pendvar
    1807 
    +        pure (k `Set.member` pending || k `Map.member` visited)
    1808 
    +
    1809 
    +      unless is_done $ do
    1810 
    +        atomically $ modifyTVar' pendvar (Set.insert k)
    1811 
    +        void $ forkIO $ -- tODO: forkIOWithUnmask, just like 'runLoop'?
    1812 
    +          go_expand ds_env visvar worklist pendvar k node
    1813 
    +
    1814 
    +    go_expand ds_env@DownsweepEnv{..} visvar worklist pendvar k node =
    1815 
    +      withAbstractSem (compile_sem ds_make_env) $ -- acquire -j par token
    1816 
    +      withLoggerHsc 1{- TODO: seq numb-} ds_make_env \ lcl_hsc_env -> do
    1817 
    +        -- todo:?
    1818 
    +        -- MC.try (mapM (run_action lcl_hsc_env) target_bundle) >>= \case
    1819 
    +        --   Left e | Just (_ :: SomeAsyncException) <- fromException e ->
    1820 
    +        --     throwIO e
    1821 
    +        --   a -> pure a
    1822 
    +
    1823 
    +        r <- runDownsweepM ds_env{ds_hsc_env = lcl_hsc_env} $
    1824 
    +             expand node -- do the main work!
    1825 
    +
    1826 
    +        case r of
    1827 
    +          NSkip ->
    1828 
    +            atomically $ modifyTVar visvar (Map.insert k NSkip)
    1829 
    +          NSuccess (v,ns) -> do
    1830 
    +            atomically $ modifyTVar visvar (Map.insert k (NSuccess v))
    1831 
    +            mapM_ (atomically . writeTQueue worklist) ns
    1832 
    +
    1833 
    +        atomically $ modifyTVar pendvar (Set.delete k)
    1796 1834
    1797 1835 
     {-
    1798 1836 
     Note [Downsweep Control Flow and Caching]
    ... ... @@ -1877,3 +1915,53 @@ twice).
    1877 1915 
     See also Note [Downsweep: building and maintaining the module graph] and
    1878 1916 
     Note [The ModuleGraph].
    1879 1917 
     -}
    1918 
    +
    1919 
    +--------------------------------------------------------------------------------
    1920 
    +-- * Concurrent utilities
    1921 
    +--------------------------------------------------------------------------------
    1922 
    +
    1923 
    +-- | Map an action over a list using the parallelism pipeline system.
    1924 
    +-- Create bundles of the list elems wrapped in a 'MakeAction' that uses
    1925 
    +-- 'withAbstractSem' to wait for a free slot, limiting the number of
    1926 
    +-- concurrently computed summaries to the value of the @-j@ option or the slots
    1927 
    +-- allocated by the job server, if that is used.
    1928 
    +--
    1929 
    +-- The 'MakeAction' returns 'Maybe', which is not handled as an error, because
    1930 
    +-- 'runLoop' only sets it to 'Nothing' when an exception was thrown, so the
    1931 
    +-- result won't be read anyway here.
    1932 
    +--
    1933 
    +-- To emulate the current behavior, we funnel exceptions past the concurrency
    1934 
    +-- barrier and rethrow the first one afterwards.
    1935 
    +mapConcDS ::
    1936 
    +  WorkerLimit ->
    1937 
    +  Int {-^ Batch size -} ->
    1938 
    +  MakeEnv ->
    1939 
    +  (HscEnv -> a -> IO b) ->
    1940 
    +  [a] ->
    1941 
    +  IO ([b])
    1942 
    +mapConcDS n_jobs bundle_size make_env run_action xs = do
    1943 
    +  (actions, get_results) <- unzip <$> mapM action_and_result (zip [1..] bundles)
    1944 
    +  runAllPipelines n_jobs make_env actions
    1945 
    +  (sequence . catMaybes <$> sequence get_results) >>= \case
    1946 
    +    Right results -> pure (concat results)
    1947 
    +    Left exc -> throwIO exc
    1948 
    +  where
    1949 
    +    bundles = mk_bundles xs
    1950 
    +
    1951 
    +    mk_bundles = unfoldr \case
    1952 
    +      [] -> Nothing
    1953 
    +      ts -> Just (splitAt bundle_size ts)
    1954 
    +
    1955 
    +    action_and_result (log_queue_id, ts) = do
    1956 
    +      res_var <- liftIO newEmptyMVar
    1957 
    +      pure $! (MakeAction (action log_queue_id ts) res_var, readMVar res_var)
    1958 
    +
    1959 
    +    action log_queue_id target_bundle = do
    1960 
    +      env@MakeEnv {compile_sem} <- ask
    1961 
    +      lift $ lift $
    1962 
    +        withAbstractSem compile_sem $
    1963 
    +        withLoggerHsc log_queue_id env \ lcl_hsc_env ->
    1964 
    +          MC.try (mapM (run_action lcl_hsc_env) target_bundle) >>= \case
    1965 
    +            Left e | Just (_ :: SomeAsyncException) <- fromException e ->
    1966 
    +              throwIO e
    1967 
    +            a -> pure a

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help Notification message regarding https://gitlab.haskell.org/ghc/ghc/-/compare/ba432fea205a721326cc4ce848f24aa77245f785...db2f5ad37f9dec233ae589a3aaf359311fecaafd at 1786629274