add descriptive field names to BlackHole heap object ; also add owner thread id field to BlackHole

Author: csabahruska

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

@@ -184,20 +184,25 @@ builtinStgEval so a@HeapPtr{} = do
   Debugger.checkBreakpoint $ BkpCustom "eval"
   case o of
     ApStack{..} -> do
+      tid <- gets ssCurrentThreadId
       let HeapPtr l = a
-      store l (BlackHole o [])  -- HINT: prevent duplicate computation
+      -- HINT: prevent duplicate computation
+      store l BlackHole
+        { hoBHOwnerThreadId = tid
+        , hoBHOriginalThunk = o
+        , hoBHWaitQueue     = []
+        }
       stackPush (Update l)      -- HINT: ensure sharing, ApStack is always created from Update frame
       mapM_ stackPush (reverse hoStack)
       pure hoResult
     RaiseException ex -> PrimExceptions.raiseEx ex
     Con{}       -> pure [a]
-
-    BlackHole ho waitingThreads -> do
+    BlackHole{..} -> do
       let HeapPtr addr = a
       tid <- gets ssCurrentThreadId
       ts <- getThreadState tid
       updateThreadState tid (ts {tsStatus = ThreadBlocked (BlockedOnBlackHole addr)})
-      store addr (BlackHole ho $ tid : waitingThreads)
+      store addr o {hoBHWaitQueue = tid : hoBHWaitQueue}
       stackPush (Apply []) -- retry evaluation next time also
       stackPush $ RunScheduler SR_ThreadBlocked
       pure [a]
@@ -252,7 +257,12 @@ builtinStgEval so a@HeapPtr{} = do
             --  read: http://mainisusuallyafunction.blogspot.com/2011/10/thunks-and-lazy-blackholes-introduction.html
             --  read: https://www.microsoft.com/en-us/research/wp-content/uploads/2005/09/2005-haskell.pdf
             stackPush (Update l)
-            store l (BlackHole o [])
+            tid <- gets ssCurrentThreadId
+            store l BlackHole
+              { hoBHOwnerThreadId = tid
+              , hoBHOriginalThunk = o
+              , hoBHWaitQueue     = []
+              }
             evalExpr extendedEnv e
           SingleEntry -> do
             tid <- gets ssCurrentThreadId
@@ -274,19 +284,24 @@ builtinStgApply so a@HeapPtr{} args = do
   case o of
     ApStack{..} -> do
       let HeapPtr l = a
-      store l (BlackHole o [])  -- HINT: prevent duplicate computation
+      tid <- gets ssCurrentThreadId
+      -- HINT: prevent duplicate computation
+      store l BlackHole
+        { hoBHOwnerThreadId = tid
+        , hoBHOriginalThunk = o
+        , hoBHWaitQueue     = []
+        }
       stackPush (Apply args)
       stackPush (Update l)      -- HINT: ensure sharing, ApStack is always created from Update frame
       mapM_ stackPush (reverse hoStack)
       pure hoResult
     RaiseException ex -> PrimExceptions.raiseEx ex
     Con{}             -> stgErrorM $ "unexpected con at apply: " ++ show o ++ ", args: " ++ show args ++ ", static-origin: " ++ show so
-
-    BlackHole ho waitingThreads -> do
+    BlackHole{..} -> do
       tid <- gets ssCurrentThreadId
       ts <- getThreadState tid
       updateThreadState tid (ts {tsStatus = ThreadBlocked (BlockedOnBlackHole addr)})
-      store addr (BlackHole ho $ tid : waitingThreads)
+      store addr o {hoBHWaitQueue = tid : hoBHWaitQueue}
       stackPush (Apply args) -- retry evaluation next time also
       stackPush $ RunScheduler SR_ThreadBlocked
       pure [a]

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

@@ -162,8 +162,11 @@ data HeapObject
     , hoCloArgs     :: [Atom]
     , hoCloMissing  :: Int    -- HINT: this is a Thunk if 0 arg is missing ; if all is missing then Fun ; Pap is some arg is provided
     }
-  | BlackHole HeapObject [Int] -- original heap object, blocking queue of thread ids
-                               -- NOTE: each blackhole has exactly one corresponding thread and one update frame
+  | BlackHole -- NOTE: each blackhole has exactly one corresponding thread and one update frame
+    { hoBHOwnerThreadId :: Int        -- owner thread id
+    , hoBHOriginalThunk :: HeapObject -- original heap object
+    , hoBHWaitQueue     :: [Int]      -- blocking queue of thread ids
+    }
   | ApStack                   -- HINT: needed for the async exceptions
     { hoResult      :: [Atom]
     , hoStack       :: [StackContinuation]
@@ -1447,7 +1450,7 @@ debugPrintHeapObject :: HeapObject -> String
 debugPrintHeapObject  = \case
   Con{..}           -> "Con: " ++ show (dcUniqueName $ unDC hoCon) ++ " " ++ show hoConArgs
   Closure{..}       -> "Clo: " ++ show hoName ++ " args: " ++ show hoCloArgs ++ " env: " ++ show (Map.size hoEnv) ++ " missing: " ++ show hoCloMissing
-  BlackHole o _q    -> "BlackHole: " ++ debugPrintHeapObject o
+  BlackHole{..}     -> "BlackHole: " ++ debugPrintHeapObject hoBHOriginalThunk
   ApStack{}         -> "ApStack"
   RaiseException ex -> "RaiseException: " ++ show ex
 
@@ -1484,9 +1487,9 @@ mylog msg = do
 
 wakeupBlackHoleQueueThreads :: Int -> M ()
 wakeupBlackHoleQueueThreads addr = readHeap (HeapPtr addr) >>= \case
-  (BlackHole _ waitingThreads) -> do
+  BlackHole{..} -> do
     -- wake up blocked threads
-    forM_ waitingThreads $ \waitingTid -> do
+    forM_ hoBHWaitQueue $ \waitingTid -> do
       waitingTS <- getThreadState waitingTid
       case tsStatus waitingTS of
         ThreadBlocked (BlockedOnBlackHole dstAddr) -> do

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

@@ -203,7 +203,7 @@ exportStgStateM stgState@StgState{..} = do
       forM_ (zip [0..] (Map.toList hoEnv)) $ \(idx, (n, a)) -> do
         addFact "Heap_ClosureEnv" [I i, I idx, ID n, A $ snd a]
 
-    BlackHole o _ -> do
+    BlackHole _ o _ -> do
       addFact "Heap_BlackHole" [I i, S (debugPrintHeapObject o)]
 
     ApStack{..} -> do

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

@@ -129,9 +129,9 @@ printHeapObject = \case
     printEnv hoEnv
     putStrLn $ "source location: " ++ (ppSrcSpan . binderDefLoc . unId $ hoName)
 
-  BlackHole ho _ -> do
+  BlackHole{..} -> do
     putStrLn "BlackHole:"
-    printHeapObject ho
+    printHeapObject hoBHOriginalThunk
     putStrLn ""
 
   ApStack{} -> do

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

@@ -26,7 +26,7 @@ instance VisitGCRef HeapObject where
   visitGCRef action = \case
     Con{..}           -> visitGCRef action hoConArgs
     Closure{..}       -> visitGCRef action hoCloArgs >> visitGCRef action hoEnv
-    BlackHole _o _q   -> pure () -- HINT: the blackhole wait queue is handled separately
+    BlackHole _ _ _   -> pure () -- HINT: the blackhole wait queue is handled separately
     ApStack{..}       -> visitGCRef action hoResult >> visitGCRef action hoStack
     RaiseException ex -> visitGCRef action ex
 

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

@@ -169,7 +169,7 @@ addReferenceFacts prog StgState{..} = do
                    , Update addr <- tsStack ts
                    ]
   forM_ blackholes $ \(tid, addr) -> case IntMap.lookup addr ssHeap of
-    Just (BlackHole _ waitingThreads) -> do
+    Just (BlackHole _ _ waitingThreads) -> do
       forM_ waitingThreads $ \waitingTid -> do
         addReference (encodeRef tid NS_Thread) (encodeRef waitingTid NS_Thread)
     ho -> error $ "internal error - expected Blackhole, got: " ++ show ho

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

@@ -312,5 +312,5 @@ removeFromMVarQueue tid m = do
 removeFromBlackHoleQueue :: Int -> Int -> M ()
 removeFromBlackHoleQueue tid addr = do
   readHeap (HeapPtr addr) >>= \case
-    (BlackHole o queue) -> modify' $ \s@StgState{..} -> s { ssHeap = IntMap.insert addr (BlackHole o $ filter (tid /=) queue) ssHeap }
-    x                   -> error $ "internal error - expected BlackHole, got: " ++ show x
+    bh@BlackHole{..}  -> modify' $ \s@StgState{..} -> s { ssHeap = IntMap.insert addr (bh {hoBHWaitQueue = filter (tid /=) hoBHWaitQueue}) ssHeap }
+    x                 -> error $ "internal error - expected BlackHole, got: " ++ show x