Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Sign up
Appearance settings

Commit 0f7f923

Browse files
implement blackhole blocking (eager blackholing, no time window for thunk duplication) ; fix RestoreExMask evaluation, it passes the current result to raiseAsyncEx which needs it for correct ApStack construction
1 parent d41bb79 commit 0f7f923

File tree

6 files changed

+81
-43
lines changed

6 files changed

+81
-43
lines changed

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

Lines changed: 30 additions & 26 deletions
Original file line numberDiff line numberDiff line change
@@ -184,26 +184,24 @@ builtinStgEval so a@HeapPtr{} = do
184184
Debugger.checkBreakpoint $ BkpCustom "eval"
185185
case o of
186186
ApStack{..} -> do
187-
stackPush (Apply []) -- ensure WHNF
187+
let HeapPtr l = a
188+
store l (BlackHole o []) -- HINT: prevent duplicate computation
189+
stackPush (Update l) -- HINT: ensure sharing, ApStack is always created from Update frame
188190
mapM_ stackPush (reverse hoStack)
189191
pure hoResult
190-
RaiseException ex -> mylog (show o) >>PrimExceptions.raiseEx ex
192+
RaiseException ex -> PrimExceptions.raiseEx ex
191193
Con{} -> pure [a]
192-
193-
BlackHole _ t -> do
194+
195+
BlackHole ho waitingThreads -> do
196+
let HeapPtr addr = a
197+
tid <- gets ssCurrentThreadId
198+
ts <- getThreadState tid
199+
updateThreadState tid (ts {tsStatus = ThreadBlocked (BlockedOnBlackHole addr)})
200+
store addr (BlackHole ho $ tid : waitingThreads)
194201
stackPush (Apply []) -- retry evaluation next time also
195-
stackPush $ RunScheduler SR_ThreadYield
202+
stackPush $ RunScheduler SR_ThreadBlocked
196203
pure [a]
197-
198-
{-
199-
-- TODO: check how the cmm stg machine handles this case
200-
BlackHole t -> do
201-
Rts{..} <- gets ssRtsSupport
202-
liftIO $ do
203-
hPutStrLn stderr $ takeBaseName rtsProgName ++ ": <<loop>>"
204-
exitWith ExitSuccess
205-
stgErrorM $ "blackhole ; loop in evaluation of : " ++ show t
206-
-}
204+
207205
Closure{..}
208206
| hoCloMissing /= 0
209207
-> pure [a]
@@ -249,21 +247,20 @@ builtinStgEval so a@HeapPtr{} = do
249247
-- closure may be entered multiple times, but should not be updated or blackholed.
250248
evalExpr extendedEnv e
251249
Updatable -> do
252-
tid <- gets ssCurrentThreadId
253250
-- closure should be updated after evaluation (and may be blackholed during evaluation).
254251
-- Q: what is eager and lazy blackholing?
255252
-- read: http://mainisusuallyafunction.blogspot.com/2011/10/thunks-and-lazy-blackholes-introduction.html
256253
-- read: https://www.microsoft.com/en-us/research/wp-content/uploads/2005/09/2005-haskell.pdf
257254
stackPush (Update l)
258-
--store l (BlackHole tid o)
255+
store l (BlackHole o [])
259256
evalExpr extendedEnv e
260257
SingleEntry -> do
261258
tid <- gets ssCurrentThreadId
262259
-- TODO: investigate how does single-entry blackholing cause problem (estgi does not have racy memops as it is mentioned in GHC Note below)
263260
-- no backholing, see: GHC Note [Black-holing non-updatable thunks]
264261
-- closure will only be entered once, and so need not be updated but may safely be blackholed.
265262
--stackPush (Update l) -- FIX??? Q: what will remove the backhole if there is no update? Q: is the value linear?
266-
--store l (BlackHole tid o) -- Q: is this a bug?
263+
--store l (BlackHole o) -- Q: is this a bug?
267264
evalExpr extendedEnv e
268265
_ -> stgErrorM $ "expected evaluable heap object, got: " ++ show a ++ " heap-object: " ++ show o ++ " static-origin: " ++ show so
269266
builtinStgEval so a = stgErrorM $ "expected a thunk, got: " ++ show a ++ ", static-origin: " ++ show so
@@ -276,18 +273,24 @@ builtinStgApply so a@HeapPtr{} args = do
276273
o <- readHeap a
277274
case o of
278275
ApStack{..} -> do
276+
let HeapPtr l = a
277+
store l (BlackHole o []) -- HINT: prevent duplicate computation
279278
stackPush (Apply args)
279+
stackPush (Update l) -- HINT: ensure sharing, ApStack is always created from Update frame
280280
mapM_ stackPush (reverse hoStack)
281281
pure hoResult
282-
RaiseException ex -> mylog (show o) >>PrimExceptions.raiseEx ex
282+
RaiseException ex -> PrimExceptions.raiseEx ex
283283
Con{} -> stgErrorM $ "unexpected con at apply: " ++ show o ++ ", args: " ++ show args ++ ", static-origin: " ++ show so
284-
--BlackHole t -> stgErrorM $ "blackhole ; loop in application of : " ++ show t
285-
{-
286-
BlackHole t -> do
287-
stackPush (Apply args)
288-
stackPush $ RunScheduler SR_ThreadYield
284+
285+
BlackHole ho waitingThreads -> do
286+
tid <- gets ssCurrentThreadId
287+
ts <- getThreadState tid
288+
updateThreadState tid (ts {tsStatus = ThreadBlocked (BlockedOnBlackHole addr)})
289+
store addr (BlackHole ho $ tid : waitingThreads)
290+
stackPush (Apply args) -- retry evaluation next time also
291+
stackPush $ RunScheduler SR_ThreadBlocked
289292
pure [a]
290-
-}
293+
291294
Closure{..}
292295
-- under saturation
293296
| hoCloMissing - argCount > 0
@@ -483,6 +486,7 @@ evalStackContinuation result = \case
483486
Update dstAddr
484487
| [src@HeapPtr{}] <- result
485488
-> do
489+
wakeupBlackHoleQueueThreads dstAddr
486490
o <- readHeap src
487491
store dstAddr o
488492
dynamicHeapStartAddr <- gets ssDynamicHeapStart
@@ -557,7 +561,7 @@ evalStackContinuation result = \case
557561
-- raise exception
558562
ts <- getCurrentThreadState
559563
updateThreadState tid ts {tsBlockedExceptions = waitingTids}
560-
PrimConcurrency.raiseAsyncEx (tsCurrentResult ts) tid exception
564+
PrimConcurrency.raiseAsyncEx result tid exception
561565
_ -> pure ()
562566
pure result
563567

‎external-stg-interpreter/lib/Stg/Interpreter/Base.hs‎

Lines changed: 18 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -162,7 +162,8 @@ data HeapObject
162162
, hoCloArgs :: [Atom]
163163
, hoCloMissing :: Int -- HINT: this is a Thunk if 0 arg is missing ; if all is missing then Fun ; Pap is some arg is provided
164164
}
165-
| BlackHole Int HeapObject
165+
| BlackHole HeapObject [Int] -- original heap object, blocking queue of thread ids
166+
-- NOTE: each blackhole has exactly one corresponding thread and one update frame
166167
| ApStack -- HINT: needed for the async exceptions
167168
{ hoResult :: [Atom]
168169
, hoStack :: [StackContinuation]
@@ -632,6 +633,7 @@ data Rts
632633
-- closures used by the GC deadlock detection
633634
, rtsBlockedIndefinitelyOnMVar :: Atom -- (exception)
634635
, rtsBlockedIndefinitelyOnSTM :: Atom -- (exception)
636+
, rtsNonTermination :: Atom -- (exception)
635637

636638
-- rts helper custom closures
637639
, rtsApplyFun1Arg :: Atom
@@ -1156,7 +1158,7 @@ NOTE:
11561158
data BlockReason
11571159
= BlockedOnMVar Int (Maybe Atom) -- mvar id, the value that need to put to mvar in case of blocking putMVar#, in case of takeMVar this is Nothing
11581160
| BlockedOnMVarRead Int -- mvar id
1159-
| BlockedOnBlackHole
1161+
| BlockedOnBlackHoleInt-- heap address
11601162
| BlockedOnThrowAsyncEx Int -- target thread id
11611163
| BlockedOnSTM TLog
11621164
| BlockedOnForeignCall -- RTS name: BlockedOnCCall
@@ -1445,7 +1447,7 @@ debugPrintHeapObject :: HeapObject -> String
14451447
debugPrintHeapObject = \case
14461448
Con{..} -> "Con: " ++ show (dcUniqueName $ unDC hoCon) ++ " " ++ show hoConArgs
14471449
Closure{..} -> "Clo: " ++ show hoName ++ " args: " ++ show hoCloArgs ++ " env: " ++ show (Map.size hoEnv) ++ " missing: " ++ show hoCloMissing
1448-
BlackHole t o -> "BlackHole - tid: "++show t ++"" ++ debugPrintHeapObject o
1450+
BlackHole o _q -> "BlackHole: " ++ debugPrintHeapObject o
14491451
ApStack{} -> "ApStack"
14501452
RaiseException ex -> "RaiseException: " ++ show ex
14511453

@@ -1478,4 +1480,16 @@ mylog msg = do
14781480
liftIO $ do
14791481
BS8.putStrLn . BS8.pack $ msg ++ " " ++ show pp ++ " " ++ show ctid
14801482
hFlush stdout
1481-
-}
1483+
-}
1484+
1485+
wakeupBlackHoleQueueThreads :: Int -> M ()
1486+
wakeupBlackHoleQueueThreads addr = readHeap (HeapPtr addr) >>= \case
1487+
(BlackHole _ waitingThreads) -> do
1488+
-- wake up blocked threads
1489+
forM_ waitingThreads $ \waitingTid -> do
1490+
waitingTS <- getThreadState waitingTid
1491+
case tsStatus waitingTS of
1492+
ThreadBlocked (BlockedOnBlackHole dstAddr) -> do
1493+
updateThreadState waitingTid (waitingTS {tsStatus = ThreadRunning})
1494+
_ -> error $ "internal error - invalid thread status: " ++ show (tsStatus waitingTS)
1495+
x -> error $ "internal error - expected BlackHole, got: " ++ show x

‎external-stg-interpreter/lib/Stg/Interpreter/Debugger/Datalog.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -203,7 +203,7 @@ exportStgStateM stgState@StgState{..} = do
203203
forM_ (zip [0..] (Map.toList hoEnv)) $ \(idx, (n, a)) -> do
204204
addFact "Heap_ClosureEnv" [I i, I idx, ID n, A $ snd a]
205205

206-
BlackHole _ o -> do
206+
BlackHole o _ -> do
207207
addFact "Heap_BlackHole" [I i, S (debugPrintHeapObject o)]
208208

209209
ApStack{..} -> do

‎external-stg-interpreter/lib/Stg/Interpreter/Debugger/UI.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -129,7 +129,7 @@ printHeapObject = \case
129129
printEnv hoEnv
130130
putStrLn $ "source location: " ++ (ppSrcSpan . binderDefLoc . unId $ hoName)
131131

132-
BlackHole _ ho -> do
132+
BlackHole ho _ -> do
133133
putStrLn "BlackHole:"
134134
printHeapObject ho
135135
putStrLn ""

‎external-stg-interpreter/lib/Stg/Interpreter/GC/LiveDataAnalysis.hs‎

Lines changed: 13 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -127,7 +127,7 @@ addGCRootFacts prog StgState{..} localGCRoots = do
127127
ThreadBlocked r -> case r of
128128
BlockedOnMVar{} -> pure () -- will be referred by the mvar wait queue
129129
BlockedOnMVarRead{} -> pure () -- will be referred by the mvar wait queue
130-
BlockedOnBlackHole{} -> error"not implemented yet"
130+
BlockedOnBlackHole{} -> pure()-- will be referred by the BlockedOnBlackHole ADDR thread status
131131
BlockedOnThrowAsyncEx{} -> pure () -- will be referred by the target thread's blocked exceptions queue
132132
BlockedOnSTM{} -> pure () -- will be referred by the tvar wait queue
133133
BlockedOnForeignCall{} -> error "not implemented yet"
@@ -163,6 +163,17 @@ addReferenceFacts prog StgState{..} = do
163163
addRefs ssStablePointers NS_StablePointer
164164
addRefs ssThreads NS_Thread
165165

166+
-- references for backhole wait queues
167+
let blackholes = [ (tid, addr)
168+
| (tid, ts) <- IntMap.toList ssThreads
169+
, Update addr <- tsStack ts
170+
]
171+
forM_ blackholes $ \(tid, addr) -> case IntMap.lookup addr ssHeap of
172+
Just (BlackHole _ waitingThreads) -> do
173+
forM_ waitingThreads $ \waitingTid -> do
174+
addReference (encodeRef tid NS_Thread) (encodeRef waitingTid NS_Thread)
175+
ho -> error $ "internal error - expected Blackhole, got: " ++ show ho
176+
166177
-- stable name references
167178
let stableNames = Map.toList ssStableNameMap
168179
forM_ stableNames $ \(v, i) -> visitGCRef (addReference (encodeRef i NS_StableName)) v
@@ -180,7 +191,7 @@ addMaybeDeadlockingThreadFacts prog StgState{..} = do
180191
ThreadBlocked r -> case r of
181192
BlockedOnMVar{} -> addMaybeDeadlockingThread $ encodeRef tid NS_Thread
182193
BlockedOnMVarRead{} -> addMaybeDeadlockingThread $ encodeRef tid NS_Thread
183-
BlockedOnBlackHole{} -> error"not implemented yet"
194+
BlockedOnBlackHole{} -> addMaybeDeadlockingThread $ encodeRef tid NS_Thread
184195
BlockedOnThrowAsyncEx{} -> addMaybeDeadlockingThread $ encodeRef tid NS_Thread
185196
BlockedOnSTM{} -> addMaybeDeadlockingThread $ encodeRef tid NS_Thread
186197
BlockedOnForeignCall{} -> error "not implemented yet"

‎external-stg-interpreter/lib/Stg/Interpreter/PrimOp/Concurrency.hs‎

Lines changed: 18 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -183,7 +183,7 @@ evalPrimOp fallback op args t tc = case (op, args) of
183183
ThreadBlocked r -> case r of
184184
BlockedOnMVar{} -> 1
185185
BlockedOnMVarRead{} -> 14
186-
BlockedOnBlackHole -> 2
186+
BlockedOnBlackHole{} -> 2
187187
BlockedOnSTM{} -> 6
188188
BlockedOnForeignCall -> 10
189189
BlockedOnRead{} -> 3
@@ -219,10 +219,12 @@ raiseAsyncEx lastResult targetTid exception = do
219219

220220
-- replace Update with ApStack
221221
Update addr : stackTail -> do
222+
when (result == []) $ error "internal error - result should be a [HeapPtr], but it's value is []"
222223
let apStack = ApStack
223224
{ hoResult = result
224225
, hoStack = reverse stackPiece
225226
}
227+
wakeupBlackHoleQueueThreads addr
226228
store addr apStack
227229
let newResult = [HeapPtr addr]
228230
ctid <- gets ssCurrentThreadId
@@ -291,17 +293,24 @@ removeFromQueues tid = do
291293
ThreadState{..} <- getThreadState tid
292294
-- Q: what about the async exception queue?
293295
case tsStatus of
294-
ThreadRunning -> pure ()
295-
ThreadBlocked (BlockedOnMVar m _) -> removeFromMVarQueue tid m
296-
ThreadBlocked (BlockedOnMVarRead m) -> removeFromMVarQueue tid m
297-
ThreadBlocked (BlockedOnSTM tlog) -> do
298-
unsubscribeTVarWaitQueues tid tlog
299-
ThreadBlocked BlockedOnDelay{} -> pure () -- HINT: no queue for delays
300-
ThreadBlocked BlockedOnRead{} -> pure () -- HINT: no queue for file read
301-
ThreadBlocked BlockedOnWrite{} -> pure () -- HINT: no queue for file write
296+
ThreadRunning -> pure ()
297+
ThreadBlocked (BlockedOnMVar m _) -> removeFromMVarQueue tid m
298+
ThreadBlocked (BlockedOnMVarRead m) -> removeFromMVarQueue tid m
299+
ThreadBlocked (BlockedOnSTM tlog) -> unsubscribeTVarWaitQueues tid tlog
300+
ThreadBlocked BlockedOnDelay{} -> pure () -- HINT: no queue for delays
301+
ThreadBlocked BlockedOnRead{} -> pure () -- HINT: no queue for file read
302+
ThreadBlocked BlockedOnWrite{} -> pure () -- HINT: no queue for file write
303+
ThreadBlocked BlockedOnThrowAsyncEx{} -> pure () -- Q: what to do?
304+
ThreadBlocked (BlockedOnBlackHole addr) -> removeFromBlackHoleQueue tid addr
302305
_ -> error $ "TODO: removeFromQueues " ++ show tsStatus
303306

304307
removeFromMVarQueue :: Int -> Int -> M ()
305308
removeFromMVarQueue tid m = do
306309
let filterFun mvd@MVarDescriptor{..} = mvd {mvdQueue = filter (tid /=) mvdQueue}
307310
modify' $ \s@StgState{..} -> s {ssMVars = IntMap.adjust filterFun m ssMVars}
311+
312+
removeFromBlackHoleQueue :: Int -> Int -> M ()
313+
removeFromBlackHoleQueue tid addr = do
314+
readHeap (HeapPtr addr) >>= \case
315+
(BlackHole o queue) -> modify' $ \s@StgState{..} -> s { ssHeap = IntMap.insert addr (BlackHole o $ filter (tid /=) queue) ssHeap }
316+
x -> error $ "internal error - expected BlackHole, got: " ++ show x

0 commit comments

Comments
(0)

AltStyle によって変換されたページ (->オリジナル) /