hls-graph: simplify AIO; scoped cancellation; fewer threads; safe cleanup

- Replace ad-hoc AIO with structured concurrency (TVar + async registry); builder returns results directly; remove lazy splitIO/unsafePerformIO
- Reduce redundant thread creation; use per-key builderOne and STM retry instead of spawning; fewer races
- Add AsyncParentKill (ThreadId, Step) and treat it as async; use cancelWith from Shake to scope cancellation to the current session
- Mask critical sections and do uninterruptible cleanup on exception (mark Dirty) to avoid stuck Running and hangs
- Adjust types/wiring (Running payload, runAIO takes Step, compute/refresh signatures); minor tweaks in ghcide Shake/Plugin.Test

Fixes #4718

Author: soulomoon

ghcide/src/Development/IDE/Core/Shake.hs

@@ -140,7 +140,8 @@ import           Development.IDE.GHC.Orphans            ()
 import           Development.IDE.Graph                  hiding (ShakeValue,
                                                          action)
 import qualified Development.IDE.Graph                  as Shake
-import           Development.IDE.Graph.Database         (ShakeDatabase,
+import           Development.IDE.Graph.Database         (AsyncParentKill (..),
+                                                         ShakeDatabase,
                                                          shakeGetBuildStep,
                                                          shakeGetDatabaseKeys,
                                                          shakeNewDatabase,
@@ -908,8 +909,11 @@ newSession recorder extras@ShakeExtras{..} vfsMod shakeDb acts reason = do
 
     --  Cancelling is required to flush the Shake database when either
     --  the filesystem or the Ghc configuration have changed
+    step <- shakeGetBuildStep shakeDb
     let cancelShakeSession :: IO ()
-        cancelShakeSession = cancel workThread
+        cancelShakeSession = do
+            tid <- myThreadId
+            cancelWith workThread $ AsyncParentKill tid step
 
     pure (ShakeSession{..})
 

ghcide/src/Development/IDE/Plugin/Test.hs

@@ -39,7 +39,7 @@ import           Development.IDE.Graph.Database       (ShakeDatabase,
                                                        shakeGetBuildStep,
                                                        shakeGetCleanKeys)
 import           Development.IDE.Graph.Internal.Types (Result (resultBuilt, resultChanged, resultVisited),
-                                                       Step (Step))
+                                                       Step)
 import qualified Development.IDE.Graph.Internal.Types as Graph
 import           Development.IDE.Types.Action
 import           Development.IDE.Types.HscEnvEq       (HscEnvEq (hscEnv))
@@ -145,7 +145,7 @@ getDatabaseKeys :: (Graph.Result -> Step)
 getDatabaseKeys field db = do
     keys <- shakeGetCleanKeys db
     step <- shakeGetBuildStep db
-    return [ k | (k, res) <- keys, field res == Step step]
+    return [ k | (k, res) <- keys, field res == step]
 
 parseAction :: CI String -> NormalizedFilePath -> Action (Either Text Bool)
 parseAction "typecheck" fp = Right . isJust <$> use TypeCheck fp

hls-graph/src/Development/IDE/Graph/Database.hs

@@ -1,4 +1,5 @@
 module Development.IDE.Graph.Database(
+    AsyncParentKill(..),
     ShakeDatabase,
     ShakeValue,
     shakeNewDatabase,
@@ -8,8 +9,8 @@ module Development.IDE.Graph.Database(
     shakeGetBuildStep,
     shakeGetDatabaseKeys,
     shakeGetDirtySet,
-    shakeGetCleanKeys
-    ,shakeGetBuildEdges) where
+    shakeGetCleanKeys,
+    shakeGetBuildEdges) where
 import           Control.Concurrent.STM.Stats            (readTVarIO)
 import           Data.Dynamic
 import           Data.Maybe
@@ -42,9 +43,9 @@ shakeGetDirtySet (ShakeDatabase _ _ db) =
     Development.IDE.Graph.Internal.Database.getDirtySet db
 
 -- | Returns the build number
-shakeGetBuildStep :: ShakeDatabase -> IO Int
+shakeGetBuildStep :: ShakeDatabase -> IO Step
 shakeGetBuildStep (ShakeDatabase _ _ db) = do
-    Step s <- readTVarIO $ databaseStep db
+    s <- readTVarIO $ databaseStep db
     return s
 
 -- Only valid if we never pull on the results, which we don't

hls-graph/src/Development/IDE/Graph/Internal/Action.hs

@@ -81,8 +81,10 @@ actionFork act k = do
 
 isAsyncException :: SomeException -> Bool
 isAsyncException e
+    | Just (_ :: SomeAsyncException) <- fromException e = True
     | Just (_ :: AsyncCancelled) <- fromException e = True
     | Just (_ :: AsyncException) <- fromException e = True
+    | Just (_ :: AsyncParentKill) <- fromException e = True
     | Just (_ :: ExitCode) <- fromException e = True
     | otherwise = False