[Git][ghc/ghc][wip/ghc-debug] Refactor ghc-heap to allow decoding TSO/STACK closures

David Eichmann gitlab at gitlab.haskell.org
Fri Oct 2 18:25:00 UTC 2020



David Eichmann pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC


Commits:
9e8e08bd by David Eichmann at 2020-10-02T19:19:29+01:00
Refactor ghc-heap to allow decoding TSO/STACK closures

* Remove getClosureDataWith in favour of the old simpler getClosureData
* Added getClosureDataFromHeapRep which is used by getClosureData and
  can be reused by ghc-debug

- - - - -


6 changed files:

- includes/rts/storage/TSO.h
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
- libraries/ghc-prim/changelog.md
- rts/Heap.c


Changes:

=====================================
includes/rts/storage/TSO.h
=====================================
@@ -255,7 +255,6 @@ typedef struct StgStack_ {
     /* Pointer to the "top" of the stack i.e. the most recently written address.
      * The stack is filled downwards, so the "top" of the stack starts with `sp
      * = stack + stack_size` and is decremented as the stack fills with data.
-     * The memory in `stack` strictly less than `sp` is free stack space.
      * See comment on "Invariants" below.
      */
     StgPtr     sp;


=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -31,8 +31,8 @@ module GHC.Exts.Heap (
     , WhatNext(..)
     , WhyBlocked(..)
     , TsoFlags(..)
-    , HasHeapRep(getClosureDataWith)
-    , getClosureData
+    , HasHeapRep(getClosureData)
+    , getClosureDataFromHeapRep
 
     -- * Info Table types
     , StgInfoTable(..)
@@ -103,108 +103,136 @@ class HasHeapRep (a :: TYPE rep) where
     -- Inside a GHC context 'b' is usually a 'GHC.Exts.Heap.Closures.Box'
     -- containing a thunk or an evaluated heap object. Outside it can be e.g.
     -- a 'Word' for "raw" usage of pointers.
-
-    getClosureDataWith ::
-        (forall c . c -> b)
-        -- ^ Convert any closure to some pointer type.
-        -> a
+    getClosureData
+        :: a
         -- ^ Closure to decode.
-        -> IO (GenClosure b)
+        -> IO Closure
         -- ^ Heap representation of the closure.
 
 instance HasHeapRep (a :: TYPE 'LiftedRep) where
-    getClosureDataWith = getClosureWith
+    getClosureData = getClosureDataFromHeapObject
 
 instance HasHeapRep (a :: TYPE 'UnliftedRep) where
-    getClosureDataWith k x = getClosureWith (k . unsafeCoerce#) (unsafeCoerce# x)
+    getClosureData x = getClosureDataFromHeapObject (unsafeCoerce# x)
 
 instance Int# ~ a => HasHeapRep (a :: TYPE 'IntRep) where
-    getClosureDataWith _ x = return $
+    getClosureData x = return $
         IntClosure { ptipe = PInt, intVal = I# x }
 
 instance Word# ~ a => HasHeapRep (a :: TYPE 'WordRep) where
-    getClosureDataWith _ x = return $
+    getClosureData x = return $
         WordClosure { ptipe = PWord, wordVal = W# x }
 
 instance Int64# ~ a => HasHeapRep (a :: TYPE 'Int64Rep) where
-    getClosureDataWith _ x = return $
+    getClosureData x = return $
         Int64Closure { ptipe = PInt64, int64Val = I64# (unsafeCoerce# x) }
 
 instance Word64# ~ a => HasHeapRep (a :: TYPE 'Word64Rep) where
-    getClosureDataWith _ x = return $
+    getClosureData x = return $
         Word64Closure { ptipe = PWord64, word64Val = W64# (unsafeCoerce# x) }
 
 instance Addr# ~ a => HasHeapRep (a :: TYPE 'AddrRep) where
-    getClosureDataWith _ x = return $
+    getClosureData x = return $
         AddrClosure { ptipe = PAddr, addrVal = I# (unsafeCoerce# x) }
 
 instance Float# ~ a => HasHeapRep (a :: TYPE 'FloatRep) where
-    getClosureDataWith _ x = return $
+    getClosureData x = return $
         FloatClosure { ptipe = PFloat, floatVal = F# x }
 
 instance Double# ~ a => HasHeapRep (a :: TYPE 'DoubleRep) where
-    getClosureDataWith _ x = return $
+    getClosureData x = return $
         DoubleClosure { ptipe = PDouble, doubleVal = D# x }
 
--- | Deconstruct any closure's heap representation.
-getClosureRaw
-    :: (forall c . c -> b)
-    -- ^ Convert any closure to some pointer type.
-    -> a
-    -- ^ Closure to deconstruct.
-    -> IO (Ptr StgInfoTable, [Word], [b])
-    -- ^ Tuple of:
-    -- * A 'Ptr' to the info table
-    -- * Non-pointer data of the closure.
-    -- * Pointer data of the closure. These are the closures pointed to by the
-    --   input closure, boxed with the given function. The pointers are
-    --   collected in @Heap.c at .
-getClosureRaw asBoxish x = do
-    case unpackClosure# x of
--- This is a hack to cover the bootstrap compiler using the old version of
--- 'unpackClosure'. The new 'unpackClosure' return values are not merely
--- a reordering, so using the old version would not work.
-#if MIN_VERSION_ghc_prim(0,5,3)
-        (# iptr, dat, pointers #) -> do
-#else
-        (# iptr, pointers, dat #) -> do
-#endif
-             let nelems = (I# (sizeofByteArray# dat)) `div` wORD_SIZE
-                 end = fromIntegral nelems - 1
-                 rawWds = [W# (indexWordArray# dat i) | I# i <- [0.. end] ]
-                 ptrList = [case indexArray# pointers i of (# ptr #) -> asBoxish ptr
-                            | I# i <- [0..(I# (sizeofArray# pointers)) - 1]
-                            ]
-             pure (Ptr iptr, rawWds, ptrList)
-
-getClosureData :: forall rep (a :: TYPE rep) . HasHeapRep a => a -> IO Closure
-getClosureData = getClosureDataWith asBox
-
 -- | Get the heap representation of a closure _at this moment_, even if it is
 -- unevaluated or an indirection or other exotic stuff. Beware when passing
 -- something to this function, the same caveats as for
 -- 'GHC.Exts.Heap.Closures.asBox' apply.
 --
 -- For most use cases 'getClosureData' is an easier to use alternative.
-getClosureWith :: forall a b.
-    (forall c . c -> b)
-    -- ^ Convert any closure to some pointer type.
-    -> a
-    -- ^ Closure to decode.
+--
+-- Currently TSO and STACK objects will return `UnsupportedClosure`. This is
+-- because it is not memory safe to extract TSO and STACK objects (done via
+-- `unpackClosure#`). Other threads may be mutating those objects and interleave
+-- with reads in `unpackClosure#`. This is particularly problematic with STACKs
+-- where pointer values may be overwritten by non-pointer values as the haskell
+-- thread runs.
+getClosureDataFromHeapObject
+    :: a
+    -- ^ Heap object to decode.
+    -> IO Closure
+    -- ^ Heap representation of the closure.
+getClosureDataFromHeapObject x = do
+    case unpackClosure# x of
+#if MIN_VERSION_ghc_prim(0,5,3)
+        (# infoTableAddr, heapRep, pointersArray #) -> do
+#else
+        -- This is a hack to cover the bootstrap compiler using the old version
+        -- of 'unpackClosure'. The new 'unpackClosure' return values are not
+        -- merely a reordering, so using the old version would not work.
+        (# infoTableAddr, pointersArray, heapRep #) -> do
+#endif
+            let infoTablePtr = Ptr infoTableAddr
+                ptrList = [case indexArray# pointersArray i of
+                                (# ptr #) -> Box ptr
+                            | I# i <- [0..(I# (sizeofArray# pointersArray)) - 1]
+                            ]
+
+            infoTable <- peekItbl infoTablePtr
+            case tipe infoTable of
+                TSO   -> pure $ UnsupportedClosure infoTable
+                STACK -> pure $ UnsupportedClosure infoTable
+                _ -> getClosureDataFromHeapRep Nothing heapRep infoTablePtr ptrList
+
+-- | Convert an unpacked heap object, to a `GenClosure b`. The inputs to this
+-- function can be generated from a heap object using `unpackClosure#`. Care
+-- must be take to ensure that the closure is not moved by the GC between
+-- calling `unpackClosure#` and reading the closure's address (the first
+-- argument to `getClosureDataFromHeapRep`).
+getClosureDataFromHeapRep
+    :: Maybe (Ptr a)
+    -- ^ Pointer to the closure in the heap. This is only used for STACK
+    -- closures to properly calculate the `stack_spOffset`. If this argument is
+    -- Nothing and the closure is a STACK, then `UnsupportedClosure` is
+    -- returned.
+    -> ByteArray#
+    -- ^ Heap representation of the closure as returned by `unpackClosure#`.
+    -- This includes all of the object including the header, info table
+    -- pointer, pointer data, and non-pointer data. The ByteArray# may be
+    -- pinned or unpinned.
+    -> Ptr StgInfoTable
+    -- ^ Pointer to the `StgInfoTable` of the closure, extracted from the heap
+    -- representation. The info table must not be moved by GC i.e. must be an
+    -- info table from this process's runtime or in pinned or off-heap memory.
+    -> [b]
+    -- ^ Pointers in the payload of the closure, extracted from the heap
+    -- representation. In the case of STACK objects, this does NOT contain
+    -- pointers in the stack space (i.e. in StgStack::stack). Note `b` is some
+    -- representation of a pointer. If for example `b ~ Any` then the referenced
+    -- objects will be managed by the runtime system and kept alive by the
+    -- garbage collector. That is not true if for example `b ~ Ptr Any`.
     -> IO (GenClosure b)
     -- ^ Heap representation of the closure.
-getClosureWith asBoxish x = do
-    (iptr, wds, pts) <- getClosureRaw asBoxish (unsafeCoerce# x)
-    itbl <- peekItbl iptr
+getClosureDataFromHeapRep closureAddressMay heapRep infoTablePtr pts = do
+    itbl <- peekItbl infoTablePtr
     -- The remaining words after the header
-    let rawWds = drop (closureTypeHeaderSize (tipe itbl)) wds
-    -- For data args in a pointers then non-pointers closure
-    -- This is incorrect in non pointers-first setups
-    -- not sure if that happens
-        npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) wds
+    let -- heapRep as a list of words.
+        rawHeapWords :: [Word]
+        rawHeapWords = [W# (indexWordArray# heapRep i) | I# i <- [0.. end] ]
+            where
+            nelems = (I# (sizeofByteArray# heapRep)) `div` wORD_SIZE
+            end = fromIntegral nelems - 1
+
+        -- Just the payload of rawHeapWords (no header).
+        payloadWords :: [Word]
+        payloadWords = drop (closureTypeHeaderSize (tipe itbl)) rawHeapWords
+
+        -- The non-pointer words in the payload. Only valid for closures with a
+        -- "pointers first" layout. Not valid for bit field layout.
+        npts :: [Word]
+        npts = drop (closureTypeHeaderSize (tipe itbl) + length pts) rawHeapWords
     case tipe itbl of
         t | t >= CONSTR && t <= CONSTR_NOCAF -> do
-            (p, m, n) <- dataConNames iptr
+            (p, m, n) <- dataConNames infoTablePtr
             if m == "GHC.ByteCode.Instr" && n == "BreakInfo"
               then pure $ UnsupportedClosure itbl
               else pure $ ConstrClosure itbl pts npts p m n
@@ -224,9 +252,9 @@ getClosureWith asBoxish x = do
             unless (length pts >= 1) $
                 fail "Expected at least 1 ptr argument to AP"
             -- We expect at least the arity, n_args, and fun fields
-            unless (length rawWds >= 2) $
+            unless (length payloadWords >= 2) $
                 fail $ "Expected at least 2 raw words to AP"
-            let splitWord = rawWds !! 0
+            let splitWord = payloadWords !! 0
             pure $ APClosure itbl
 #if defined(WORDS_BIGENDIAN)
                 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
@@ -241,9 +269,9 @@ getClosureWith asBoxish x = do
             unless (length pts >= 1) $
                 fail "Expected at least 1 ptr argument to PAP"
             -- We expect at least the arity, n_args, and fun fields
-            unless (length rawWds >= 2) $
+            unless (length payloadWords >= 2) $
                 fail "Expected at least 2 raw words to PAP"
-            let splitWord = rawWds !! 0
+            let splitWord = payloadWords !! 0
             pure $ PAPClosure itbl
 #if defined(WORDS_BIGENDIAN)
                 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
@@ -278,10 +306,10 @@ getClosureWith asBoxish x = do
             unless (length pts >= 3) $
                 fail $ "Expected at least 3 ptr argument to BCO, found "
                         ++ show (length pts)
-            unless (length rawWds >= 4) $
+            unless (length payloadWords >= 4) $
                 fail $ "Expected at least 4 words to BCO, found "
-                        ++ show (length rawWds)
-            let splitWord = rawWds !! 3
+                        ++ show (length payloadWords)
+            let splitWord = payloadWords !! 3
             pure $ BCOClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
 #if defined(WORDS_BIGENDIAN)
                 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
@@ -290,25 +318,25 @@ getClosureWith asBoxish x = do
                 (fromIntegral splitWord)
                 (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
 #endif
-                (drop 4 rawWds)
+                (drop 4 payloadWords)
 
         ARR_WORDS -> do
-            unless (length rawWds >= 1) $
+            unless (length payloadWords >= 1) $
                 fail $ "Expected at least 1 words to ARR_WORDS, found "
-                        ++ show (length rawWds)
-            pure $ ArrWordsClosure itbl (head rawWds) (tail rawWds)
+                        ++ show (length payloadWords)
+            pure $ ArrWordsClosure itbl (head payloadWords) (tail payloadWords)
 
         t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> do
-            unless (length rawWds >= 2) $
+            unless (length payloadWords >= 2) $
                 fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
-                        ++ "found " ++ show (length rawWds)
-            pure $ MutArrClosure itbl (rawWds !! 0) (rawWds !! 1) pts
+                        ++ "found " ++ show (length payloadWords)
+            pure $ MutArrClosure itbl (payloadWords !! 0) (payloadWords !! 1) pts
 
         t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> do
-            unless (length rawWds >= 1) $
+            unless (length payloadWords >= 1) $
                 fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
-                        ++ "found " ++ show (length rawWds)
-            pure $ SmallMutArrClosure itbl (rawWds !! 0) pts
+                        ++ "found " ++ show (length payloadWords)
+            pure $ SmallMutArrClosure itbl (payloadWords !! 0) pts
 
         t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> do
             unless (length pts >= 1) $
@@ -323,11 +351,11 @@ getClosureWith asBoxish x = do
             pure $ MVarClosure itbl (pts !! 0) (pts !! 1) (pts !! 2)
 
         BLOCKING_QUEUE ->
-            pure $ OtherClosure itbl pts wds
+            pure $ OtherClosure itbl pts rawHeapWords
         --    pure $ BlockingQueueClosure itbl
         --        (pts !! 0) (pts !! 1) (pts !! 2) (pts !! 3)
 
-        --  pure $ OtherClosure itbl pts wds
+        --  pure $ OtherClosure itbl pts rawHeapWords
         --
         WEAK ->
             pure $ WeakClosure
@@ -339,16 +367,16 @@ getClosureWith asBoxish x = do
                 , link = pts !! 4
                 }
         TSO | [ u_lnk, u_gbl_lnk, tso_stack, u_trec, u_blk_ex, u_bq] <- pts
-                -> withArray wds (\ptr -> do
+                -> withArray rawHeapWords (\ptr -> do
                     fields <- FFIClosures.peekTSOFields peekStgTSOProfInfo ptr
                     pure $ TSOClosure
                         { info = itbl
-                        , unsafe_link = u_lnk
-                        , unsafe_global_link = u_gbl_lnk
+                        , link = u_lnk
+                        , global_link = u_gbl_lnk
                         , tsoStack = tso_stack
-                        , unsafe_trec = u_trec
-                        , unsafe_blocked_exceptions = u_blk_ex
-                        , unsafe_bq = u_bq
+                        , trec = u_trec
+                        , blocked_exceptions = u_blk_ex
+                        , bq = u_bq
                         , what_next = FFIClosures.tso_what_next fields
                         , why_blocked = FFIClosures.tso_why_blocked fields
                         , flags = FFIClosures.tso_flags fields
@@ -362,27 +390,30 @@ getClosureWith asBoxish x = do
             | otherwise
                 -> fail $ "Expected 6 ptr arguments to TSO, found "
                         ++ show (length pts)
-        STACK   | [u_sp] <- pts
-                    -> withArray wds (\ptr -> do
+        STACK
+            | [] <- pts
+            -> case closureAddressMay of
+                Nothing -> pure $ UnsupportedClosure itbl
+                Just (Ptr closureAddress) ->  withArray rawHeapWords (\ptr -> do
                             fields <- FFIClosures.peekStackFields ptr
-
+                            let sp = FFIClosures.stack_sp fields
+                                spOffset = I# (minusAddr# sp closureAddress)
                             pure $ StackClosure
                                 { info = itbl
                                 , stack_size = FFIClosures.stack_size fields
                                 , stack_dirty = FFIClosures.stack_dirty fields
-                                , unsafeStackPointer = u_sp
-                                , unsafeStack  = FFIClosures.stack fields
 #if __GLASGOW_HASKELL__ >= 811
                                 , stack_marking = FFIClosures.stack_marking fields
 #endif
+                                , stack_spOffset = spOffset
                                 })
-                | otherwise
-                    -> fail $ "Expected 1 ptr argument to STACK, found "
-                        ++ show (length pts)
+            | otherwise
+                -> fail $ "Expected 0 ptr argument to STACK, found "
+                    ++ show (length pts)
 
         _ ->
             pure $ UnsupportedClosure itbl
 
--- | Like 'getClosureDataWith', but taking a 'Box', so it is easier to work with.
+-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
 getBoxedClosureData :: Box -> IO Closure
 getBoxedClosureData (Box a) = getClosureData a


=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -105,11 +105,17 @@ type Closure = GenClosure Box
 -- | This is the representation of a Haskell value on the heap. It reflects
 -- <https://gitlab.haskell.org/ghc/ghc/blob/master/includes/rts/storage/Closures.h>
 --
--- The data type is parametrized by the type to store references in. Usually
--- this is a 'Box' with the type synonym 'Closure'.
+-- The data type is parametrized by `b`: the type to store references in.
+-- Usually this is a 'Box' with the type synonym 'Closure'.
 --
--- All Heap objects have the same basic layout. A header containing a pointer
--- to the info table and a payload with various fields. The @info@ field below
+-- If you are observing closures from an external process, extra care must be
+-- taken when dealing with `b` references. The external process's GC may move or
+-- free the objects. If you plan on using the `b` references, you should pause
+-- the external process's GC for example with `rts_lock` or `rts_pause` form
+-- `RtsAPI.h`.
+--
+-- All Heap objects have the same basic layout. A header containing a pointer to
+-- the info table and a payload with various fields. The @info@ field below
 -- always refers to the info table pointed to by the header. The remaining
 -- fields are the payload.
 --
@@ -273,46 +279,50 @@ data GenClosure b
         , link        :: !b -- ^ next weak pointer for the capability, can be NULL.
         }
 
-  -- | Representation of StgTSO: A Thread State Object.
-  -- The values for 'what_next', 'why_blocked' and 'flags' are defined in
-  -- @Constants.h at .
-  -- Fields marked as @unsafe@ are backed by dynamic pointers and should only
-  -- be accessed when the garbage collector is stopped. Otherwise segmentation
-  -- faults may happen when an invalidated pointer is accessed.
+  -- | Representation of StgTSO: A Thread State Object. The values for
+  -- 'what_next', 'why_blocked' and 'flags' are defined in @Constants.h at .
   | TSOClosure
-      { info :: !StgInfoTable
+      { info                :: !StgInfoTable
       -- pointers
-      , unsafe_link :: !b
-      , unsafe_global_link :: !b
-      , tsoStack :: !b -- ^ stackobj from StgTSO
-      , unsafe_trec :: !b
-      , unsafe_blocked_exceptions :: !b
-      , unsafe_bq :: !b
+      , link                :: !b
+      , global_link         :: !b
+      , tsoStack            :: !b -- ^ stackobj from StgTSO
+      , trec                :: !b
+      , blocked_exceptions  :: !b
+      , bq                  :: !b
       -- values
-      , what_next :: WhatNext
-      , why_blocked :: WhyBlocked
-      , flags :: [TsoFlags]
-      , threadId :: Word64
-      , saved_errno :: Word32
-      , tso_dirty:: Word32 -- ^ non-zero => dirty
-      , alloc_limit :: Int64
-      , tot_stack_size :: Word32
-      , prof :: Maybe StgTSOProfInfo
+      , what_next           :: !WhatNext
+      , why_blocked         :: !WhyBlocked
+      , flags               :: ![TsoFlags]
+      , threadId            :: !Word64
+      , saved_errno         :: !Word32
+      , tso_dirty           :: !Word32 -- ^ non-zero => dirty
+      , alloc_limit         :: !Int64
+      , tot_stack_size      :: !Word32
+      , prof                :: !(Maybe StgTSOProfInfo)
       }
-  -- | Representation of StgStack: The 'tsoStack' of a 'TSOClosure'.
-  -- Fields marked as @unsafe@ are backed by dynamic pointers and should only
-  -- be accessed when the garbage collector is stopped. Otherwise segmentation
-  -- faults may happen when an invalidated pointer is accessed.
+
+  -- | Representation of StgStack: The 'tsoStack ' of a 'TSOClosure'.
+  --
+  -- Fields marked as @unsafe@ contain pointers to data that might be moved by
+  -- the RTS at any point (e.g. by the garbage collector or the scheduler).
+  -- These unsafe fields should only be accessed when all haskell threads are
+  -- paused, typically via GHC's `rts_pause` fucntion in `RtsAPI.h`.
+  -- Unfortunately, you need a running haskell thread to observe these fields in
+  -- the first place! Still, you can safely make use of these fields if the
+  -- closure is from an external Haskell process with a paused RTS.
   | StackClosure
-     { info :: !StgInfoTable
-     , stack_size :: !Word32 -- ^ stack size in *words*
-     , stack_dirty :: !Word8 -- ^ non-zero => dirty
+      { info            :: !StgInfoTable
+      , stack_size      :: !Word32 -- ^ stack size in *words*
+      , stack_dirty     :: !Word8 -- ^ non-zero => dirty
 #if __GLASGOW_HASKELL__ >= 810
-     , stack_marking :: Word8
+      , stack_marking   :: !Word8
 #endif
-     , unsafeStackPointer :: !b -- ^ current stack pointer
-     , unsafeStack :: [Word]
-     }
+      -- | Offset of the `StgStack::sp` pointer in bytes
+      --    x->sp == ((byte*)x)+stack_spOffset
+      --  The type of `stack_spOffset` reflects the type of `stack_size`.
+      , stack_spOffset  :: !Int
+      }
 
     ------------------------------------------------------------
     -- Unboxed unlifted closures


=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
=====================================
@@ -1,10 +1,13 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE MagicHash #-}
+
 module GHC.Exts.Heap.FFIClosures where
 
 #include "Rts.h"
 
 import Prelude
 import Foreign
+import GHC.Exts
 import GHC.Exts.Heap.ProfInfo.Types
 import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
 
@@ -100,7 +103,7 @@ data StackFields = StackFields {
 #if __GLASGOW_HASKELL__ >= 810
     stack_marking :: Word8,
 #endif
-    stack :: [Word]
+    stack_sp :: Addr##
 }
 
 -- | Get non-closure fields from @StgStack_@ (@TSO.h@)
@@ -111,9 +114,9 @@ peekStackFields ptr = do
 #if __GLASGOW_HASKELL__ >= 810
     marking' <- (#peek struct StgStack_, marking) ptr
 #endif
+    Ptr sp' <- (#peek struct StgStack_, sp) ptr
 
-    let stackPtr = (#ptr struct StgStack_, stack) ptr
-    stack' <- peekArray (fromIntegral stack_size') stackPtr
+    -- TODO decode the stack.
 
     return StackFields {
         stack_size = stack_size',
@@ -121,5 +124,5 @@ peekStackFields ptr = do
 #if __GLASGOW_HASKELL__ >= 810
         stack_marking = marking',
 #endif
-        stack = stack'
+        stack_sp = sp'
     }


=====================================
libraries/ghc-prim/changelog.md
=====================================
@@ -5,7 +5,7 @@
 - Add known-key `cstringLength#` to `GHC.CString`. This is just the
   C function `strlen`, but a built-in rewrite rule allows GHC to
   compute the result at compile time when the argument is known.
-  
+
 - In order to support unicode better the following functions in `GHC.CString`
   gained UTF8 counterparts:
 


=====================================
rts/Heap.c
=====================================
@@ -224,10 +224,6 @@ StgWord collect_pointers(StgClosure *closure, StgWord size, StgClosure *ptrs[siz
             ASSERT((StgClosure *)((StgTSO *)closure)->bq != NULL);
             ptrs[nptrs++] = (StgClosure *)((StgTSO *)closure)->bq;
 
-            break;
-        case STACK:
-            ASSERT((StgClosure *)((StgStack *)closure)->sp != NULL);
-            ptrs[nptrs++] = (StgClosure *)((StgStack *)closure)->sp;
             break;
         case WEAK:
             ptrs[nptrs++] = (StgClosure *)((StgWeak *)closure)->cfinalizers;



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e8e08bdc063d86fcd5c4f5ac11bd35407c103fd

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9e8e08bdc063d86fcd5c4f5ac11bd35407c103fd
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20201002/e6359a63/attachment-0001.html>


More information about the ghc-commits mailing list