@@ -14,6 +14,7 @@ import Data.Maybe
1414
1515import Stg.Syntax
1616import Stg.Interpreter.Base
17+ import qualified Stg.Interpreter.PrimOp.Concurrency as PrimConcurrency
1718
1819{-
1920 STM design notes
@@ -335,25 +336,31 @@ retrySTM = unwindStack where
335336 putStrLn $ " [STM] tid: " ++ show tid ++ " tlog: " ++ show tlog
336337 putStrLn $ " [STM] validateTLog: " ++ show isValid
337338
338- if isValid
339+ if ( not isValid)
339340 then do
341+ restartTransaction stmAction
342+ else do
340343 promptM $ putStrLn $ " [STM] retry, block thread, tid: " ++ show tid
341344 tid <- gets ssCurrentThreadId
342345 ts <- getThreadState tid
343346 -- subscribe to wait queues
344347 let Just tlog = tsActiveTLog ts
345- when (IntMap. size tlog == 0 ) $ error " internal error: IntMap.sie tlog == 0 on BlockedOnSTM"
346- subscribeTVarWaitQueues tid tlog
347- -- suspend thread
348- updateThreadState tid (ts {tsStatus = ThreadBlocked (BlockedOnSTM tlog), tsActiveTLog = Just mempty })
349- -- Q: who will update the tsTLog after the wake up?
350- stackPush $ Atomically stmAction
351- stackPush $ Apply [Void ]
352- stackPush $ RunScheduler SR_ThreadBlocked
353- pure [stmAction]
354- 355- else do
356- restartTransaction stmAction
348+ case IntMap. null tlog of
349+ True -> do
350+ -- HINT: the transaction log is empty, so there is no TVar to subscribe, therefore the transaction is blocked indefinitely
351+ updateThreadState tid (ts {tsActiveTLog = Nothing })
352+ Rts {.. } <- gets ssRtsSupport
353+ PrimConcurrency. raiseAsyncEx [] tid rtsBlockedIndefinitelyOnSTM
354+ pure []
355+ False -> do
356+ subscribeTVarWaitQueues tid tlog
357+ -- suspend thread
358+ updateThreadState tid (ts {tsStatus = ThreadBlocked (BlockedOnSTM tlog), tsActiveTLog = Just mempty })
359+ -- Q: who will update the tsTLog after the wake up?
360+ stackPush $ Atomically stmAction
361+ stackPush $ Apply [Void ]
362+ stackPush $ RunScheduler SR_ThreadBlocked
363+ pure [stmAction]
357364
358365 _ -> unwindStack -- HINT: discard stack frames
359366
0 commit comments