add non-termination handling to deadlock detection

Author: csabahruska

external-stg-interpreter/lib/Stg/Interpreter/GC/DeadlockAnalysis.hs

@@ -29,7 +29,7 @@ validateGCThreadResult RefSet{..} deadlockedThreadIds = do
     ThreadBlocked r -> case r of
       BlockedOnMVar{}         -> assertLiveOrDeadlocked tid
       BlockedOnMVarRead{}     -> assertLiveOrDeadlocked tid
-      BlockedOnBlackHole{}    -> error "not implemented yet"
+      BlockedOnBlackHole{}    -> assertLiveOrDeadlocked tid
       BlockedOnThrowAsyncEx{} -> assertLiveOrDeadlocked tid
       BlockedOnSTM{}          -> assertLiveOrDeadlocked tid
       BlockedOnForeignCall{}  -> error "not implemented yet"
@@ -45,14 +45,21 @@ handleDeadlockedThreads deadlockedThreadIds = do
   Rts{..} <- gets ssRtsSupport
   let raiseEx targetTid exception = do
         PrimConcurrency.removeFromQueues targetTid
-        PrimConcurrency.raiseAsyncEx [] targetTid exception
-  forM_ (IntSet.toList deadlockedThreadIds) $ \tid -> do
+        targetTS <- getThreadState targetTid
+        PrimConcurrency.raiseAsyncEx (tsCurrentResult targetTS) targetTid exception
+  tsMap <- gets ssThreads
+  forM_ (reverse $ IntSet.toList deadlockedThreadIds) $ \tid -> do
     ts <- getThreadState tid
     case tsStatus ts of
+      ThreadRunning
+        -- HINT: during async excepion stack unwind, Update frames can wake up threads that were blocking on blackholes
+        | Just originalTS <- IntMap.lookup tid tsMap
+        , ThreadBlocked BlockedOnBlackHole{} <- tsStatus originalTS
+        -> pure ()
       ThreadBlocked r -> case r of
         BlockedOnMVar{}         -> raiseEx tid rtsBlockedIndefinitelyOnMVar
         BlockedOnMVarRead{}     -> raiseEx tid rtsBlockedIndefinitelyOnMVar
-        BlockedOnBlackHole{}    -> error "not implemented yet"
+        BlockedOnBlackHole{}    -> raiseEx tid rtsNonTermination
         BlockedOnThrowAsyncEx{} -> pure () -- HINT: it might be blocked on other deadlocked thread
         BlockedOnSTM{}          -> raiseEx tid rtsBlockedIndefinitelyOnSTM
         BlockedOnForeignCall{}  -> error "not implemented yet"

external-stg-interpreter/lib/Stg/Interpreter/Rts.hs

@@ -152,6 +152,7 @@ wiredInClosures =
   , (":ext-stg",  ":ExtStg.RTS.Support",    "applyFun1Arg",                 \s cl -> s {rtsApplyFun1Arg               = cl})
   , (":ext-stg",  ":ExtStg.RTS.Support",    "tuple2Proj0",                  \s cl -> s {rtsTuple2Proj0                = cl})
   , ("base",      "Control.Exception.Base", "nestedAtomically",             \s cl -> s {rtsNestedAtomically           = cl})
+  , ("base",      "Control.Exception.Base", "nonTermination",               \s cl -> s {rtsNonTermination             = cl})
   , ("base",      "GHC.IO.Exception",       "blockedIndefinitelyOnMVar",    \s cl -> s {rtsBlockedIndefinitelyOnMVar  = cl})
   , ("base",      "GHC.IO.Exception",       "blockedIndefinitelyOnSTM",     \s cl -> s {rtsBlockedIndefinitelyOnSTM   = cl})
   ]
@@ -165,7 +166,6 @@ wiredInClosures =
   , ("base",      "GHC.IO.Exception",       "cannotCompactPinned",
   , ("base",      "GHC.IO.Exception",       "cannotCompactMutable",
   , ("base",      "Control.Exception.Base", "absentSumFieldError",
-  , ("base",      "Control.Exception.Base", "nonTermination",
   , ("base",      "GHC.Event.Thread",       "blockedOnBadFD",
   , ("base",      "GHC.Conc.Sync",          "runSparks",
   , ("base",      "GHC.Conc.IO",            "ensureIOManagerIsRunning",