GitLab

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

Commits:

02b3b6ee
by Rodrigo Mesquita at 2026-08-14T13:32:58+01:00
```
fixup: Add mask_ to parent forkIOWithUnmask
```

c65f7a6e

by Rodrigo Mesquita at 2026-08-14T13:38:13+01:00

fixup: reduce transactions, put together sequentially together ones

b8695cd3
by Rodrigo Mesquita at 2026-08-14T13:56:58+01:00
```
fixup: keep track of worker threads
```

Changes:

compiler/GHC/Driver/Downsweep.hs

@@ -1787,9 +1787,10 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do
      visited_var <- newTVarIO (fromMaybe Map.empty base_map)
      pending     <- newTVarIO Set.empty
      worklist    <- newTQueueIO
 +    threads     <- newTVarIO []
      coord_tid   <- forkIO $
 -      coordinator ds_env exc_var visited_var worklist pending
 +      coordinator ds_env exc_var visited_var worklist pending threads
          `MC.catch` \case
            (e::MC.SomeException)
              -- exit cleanly when killed
@@ -1798,11 +1799,12 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do
              -- signal the exc_var for the main thread to throw it
              | otherwise -> atomically (modifyTVar' exc_var (<|> Just e))
 -    mapM_ (atomically . writeTQueue worklist) roots
 +    atomically $ mapM_ (writeTQueue worklist) roots
      mb_exc <- wait_done exc_var worklist pending
        `MC.finally` do
          killThread coord_tid
 +        mapM_ killThread =<< readTVarIO threads
      case mb_exc of
        Just e  -> throwIO e
@@ -1820,7 +1822,7 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do
              unless (empty_worklist && empty_pending) retry
              return Nothing
 -    coordinator ds_env exc_var visvar worklist pendvar = forever $ do
 +    coordinator ds_env exc_var visvar worklist pendvar threads = forever $ do
        mb_node_to_expand <- atomically $ do
          node <- readTQueue worklist
          let k = key node
@@ -1839,27 +1841,32 @@ parDfsBuild base_map roots key expand = ReaderT $ \ds_env -> do
        case mb_node_to_expand of
          Nothing        -> return ()
 -        Just (k, node) -> void $ do
 -          withLocalTmpFSMake (ds_make_env ds_env) $ \make_env ->
 -            forkIOWithUnmask $ \unmask ->
 +        Just (k, node) -> do
 +          tid <- withLocalTmpFSMake (ds_make_env ds_env) $ \make_env ->
 +            MC.mask_ $ forkIOWithUnmask $ \unmask ->
                unmask (worker ds_env{ds_make_env = make_env} visvar worklist pendvar k node)
 -                -- write exception in the worker to the main thread
 -                `MC.catch` \(e::MC.SomeException) ->
 -                  atomically (modifyTVar' exc_var (<|> Just e))
 +                `MC.catch` \case
 +                  e | Just (_ :: SomeAsyncException) <- fromException e
 +                    -> throwIO e -- async exceptions like KillThread get thrown
 +                    | otherwise  -- exceptions in workers are written for main thread
 +                    -> atomically (modifyTVar' exc_var (<|> Just e))
++
 +          atomically $ modifyTVar' threads (tid:)
      worker ds_env@DownsweepEnv{..} visvar worklist pendvar k node =
        withAbstractSem (compile_sem ds_make_env) $ do
          r <- runDownsweepM ds_env $
               expand node -- do the main work!
 -        case r of
 -          NSkip ->
 -            atomically $ modifyTVar' visvar (Map.insert k NSkip)
 -          NSuccess (v,ns) -> do
 -            atomically $ modifyTVar' visvar (Map.insert k (NSuccess v))
 -            mapM_ (atomically . writeTQueue worklist) ns
 +        atomically $ do
 +          case r of
 +            NSkip ->
 +              modifyTVar' visvar (Map.insert k NSkip)
 +            NSuccess (v,ns) -> do
 +              modifyTVar' visvar (Map.insert k (NSuccess v))
 +              mapM_ (writeTQueue worklist) ns
 -        atomically $ modifyTVar' pendvar (Set.delete k)
 +          modifyTVar' pendvar (Set.delete k)
  {-
  Note [Downsweep Control Flow and Caching]

compiler/GHC/Driver/MakeAction.hs

@@ -185,7 +185,8 @@ runLoop fork_thread env (MakeAction act res_var :acts) = do
    -- withLocalTmpFs has to occur outside of fork to remain deterministic
    new_thread <- withLocalTmpFSMake env $ \lcl_env ->
 -    fork_thread $ \unmask -> (do
 +    MC.mask_ $
 +      fork_thread $ \unmask -> (do
              mres <- (unmask $ run_pipeline lcl_env act)
                        `MC.onException` (putMVar res_var Nothing) -- Defensive: If there's an unhandled exception then still signal the failure.
              putMVar res_var mres)