[Git][ghc/ghc][wip/decode_cloned_stack] Minimize diff
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Apr 9 14:20:37 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
75c42867 by Sven Tennie at 2023-04-09T14:20:06+00:00
Minimize diff
- - - - -
8 changed files:
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- − libraries/ghc-heap/GHC/Exts/Heap/Decode.hs
- + libraries/ghc-heap/GHC/Exts/Stack.hs
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/ghc-heap.cabal.in
- libraries/ghc-heap/tests/ClosureSizeUtils.hs
- libraries/ghc-heap/tests/stack_misc_closures.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -7,9 +7,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RankNTypes #-}
-#if MIN_TOOL_VERSION_ghc(9,7,0)
-{-# LANGUAGE RecordWildCards #-}
-#endif
{-# LANGUAGE UnliftedFFITypes #-}
{-|
@@ -26,12 +23,10 @@ module GHC.Exts.Heap (
-- * Closure types
Closure
, GenClosure(..)
- , StackFrame(..)
, ClosureType(..)
, PrimType(..)
, WhatNext(..)
, WhyBlocked(..)
- , RetFunType(..)
, TsoFlags(..)
, HasHeapRep(getClosureData)
, getClosureDataFromHeapRep
@@ -55,12 +50,7 @@ module GHC.Exts.Heap (
-- * Closure inspection
, getBoxedClosureData
, allClosures
- , closureSize
-#if MIN_TOOL_VERSION_ghc(9,7,0)
- -- * Stack inspection
- , decodeStack
- , stackFrameSize
-#endif
+
-- * Boxes
, Box(..)
, asBox
@@ -70,22 +60,22 @@ module GHC.Exts.Heap (
import Prelude
import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.ClosureTypes
+import GHC.Exts.Heap.Constants
import GHC.Exts.Heap.ProfInfo.Types
#if defined(PROFILING)
import GHC.Exts.Heap.InfoTableProf
#else
import GHC.Exts.Heap.InfoTable
#endif
-import GHC.Exts.Heap.Decode
+import GHC.Exts.Heap.Utils
+import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
+import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI
+import Data.Bits
+import Foreign
import GHC.Exts
import GHC.Int
import GHC.Word
-#if MIN_TOOL_VERSION_ghc(9,7,0)
-import GHC.Exts.Stack.Decode
-import GHC.Exts.Stack.Constants
-#endif
-
#include "ghcconfig.h"
@@ -173,34 +163,223 @@ getClosureDataFromHeapObject x = do
STACK -> pure $ UnsupportedClosure infoTable
_ -> getClosureDataFromHeapRep 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#`.
+getClosureDataFromHeapRep :: ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
+getClosureDataFromHeapRep heapRep infoTablePtr pts = do
+ itbl <- peekItbl infoTablePtr
+ getClosureDataFromHeapRepPrim (dataConNames infoTablePtr) PPI.peekTopCCS itbl heapRep pts
+
+getClosureDataFromHeapRepPrim
+ :: IO (String, String, String)
+ -- ^ A continuation used to decode the constructor description field,
+ -- in ghc-debug this code can lead to segfaults because dataConNames
+ -- will dereference a random part of memory.
+ -> (Ptr a -> IO (Maybe CostCentreStack))
+ -- ^ A continuation which is used to decode a cost centre stack
+ -- In ghc-debug, this code will need to call back into the debuggee to
+ -- fetch the representation of the CCS before decoding it. Using
+ -- `peekTopCCS` for this argument can lead to segfaults in ghc-debug as
+ -- the CCS argument will point outside the copied closure.
+ -> StgInfoTable
+ -- ^ The `StgInfoTable` of the closure, extracted from the heap
+ -- representation.
+ -> 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.
+ -> [b]
+ -- ^ Pointers in the payload of the closure, extracted from the heap
+ -- representation as returned by `collect_pointers()` in `Heap.c`. The type
+ -- `b` is some representation of a pointer e.g. `Any` or `Ptr Any`.
+ -> IO (GenClosure b)
+ -- ^ Heap representation of the closure.
+getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
+ 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) <- getConDesc
+ pure $ ConstrClosure itbl pts npts p m n
+
+ t | t >= THUNK && t <= THUNK_STATIC -> do
+ pure $ ThunkClosure itbl pts npts
+
+ THUNK_SELECTOR -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
+ hd : _ -> pure $ SelectorClosure itbl hd
+
+ t | t >= FUN && t <= FUN_STATIC -> do
+ pure $ FunClosure itbl pts npts
+
+ AP -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to AP"
+ hd : tl -> case payloadWords of
+ -- We expect at least the arity, n_args, and fun fields
+ splitWord : _ : _ ->
+ pure $ APClosure itbl
+#if defined(WORDS_BIGENDIAN)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
+#else
+ (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+#endif
+ hd tl
+ _ -> fail "Expected at least 2 raw words to AP"
+
+ PAP -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to PAP"
+ hd : tl -> case payloadWords of
+ -- We expect at least the arity, n_args, and fun fields
+ splitWord : _ : _ ->
+ pure $ PAPClosure itbl
+#if defined(WORDS_BIGENDIAN)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
+#else
+ (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+#endif
+ hd tl
+ _ -> fail "Expected at least 2 raw words to PAP"
+
+ AP_STACK -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to AP_STACK"
+ hd : tl -> pure $ APStackClosure itbl hd tl
+
+ IND -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to IND"
+ hd : _ -> pure $ IndClosure itbl hd
+
+ IND_STATIC -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to IND_STATIC"
+ hd : _ -> pure $ IndClosure itbl hd
+
+ BLACKHOLE -> case pts of
+ [] -> fail "Expected at least 1 ptr argument to BLACKHOLE"
+ hd : _ -> pure $ BlackholeClosure itbl hd
+
+ BCO -> case pts of
+ pts0 : pts1 : pts2 : _ -> case payloadWords of
+ _ : _ : _ : splitWord : payloadRest ->
+ pure $ BCOClosure itbl pts0 pts1 pts2
+#if defined(WORDS_BIGENDIAN)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+ (fromIntegral splitWord)
+#else
+ (fromIntegral splitWord)
+ (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
+#endif
+ payloadRest
+ _ -> fail $ "Expected at least 4 words to BCO, found "
+ ++ show (length payloadWords)
+ _ -> fail $ "Expected at least 3 ptr argument to BCO, found "
+ ++ show (length pts)
+
+ ARR_WORDS -> case payloadWords of
+ [] -> fail $ "Expected at least 1 words to ARR_WORDS, found "
+ ++ show (length payloadWords)
+ hd : tl -> pure $ ArrWordsClosure itbl hd tl
+
+ t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
+ p0 : p1 : _ -> pure $ MutArrClosure itbl p0 p1 pts
+ _ -> fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
+ ++ "found " ++ show (length payloadWords)
+
+ t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
+ [] -> fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
+ ++ "found " ++ show (length payloadWords)
+ hd : _ -> pure $ SmallMutArrClosure itbl hd pts
+
+ t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> case pts of
+ [] -> fail $ "Expected at least 1 words to MUT_VAR, found "
+ ++ show (length pts)
+ hd : _ -> pure $ MutVarClosure itbl hd
+
+ t | t == MVAR_CLEAN || t == MVAR_DIRTY -> case pts of
+ pts0 : pts1 : pts2 : _ -> pure $ MVarClosure itbl pts0 pts1 pts2
+ _ -> fail $ "Expected at least 3 ptrs to MVAR, found "
+ ++ show (length pts)
+
+ BLOCKING_QUEUE ->
+ pure $ OtherClosure itbl pts rawHeapWords
+
+ WEAK -> case pts of
+ pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure
+ { info = itbl
+ , cfinalizers = pts0
+ , key = pts1
+ , value = pts2
+ , finalizer = pts3
+ , weakLink = case rest of
+ [] -> Nothing
+ [p] -> Just p
+ _ -> error $ "Expected 4 or 5 words in WEAK, but found more: " ++ show (length pts)
+ }
+ _ -> error $ "Expected 4 or 5 words in WEAK, but found less: " ++ show (length pts)
+ TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other) <- pts
+ -> withArray rawHeapWords (\ptr -> do
+ fields <- FFIClosures.peekTSOFields decodeCCS ptr
+ pure $ TSOClosure
+ { info = itbl
+ , link = u_lnk
+ , global_link = u_gbl_lnk
+ , tsoStack = tso_stack
+ , trec = u_trec
+ , blocked_exceptions = u_blk_ex
+ , bq = u_bq
+ , thread_label = case other of
+ [tl] -> Just tl
+ [] -> Nothing
+ _ -> error $ "thead_label:Expected 0 or 1 extra arguments"
+ , what_next = FFIClosures.tso_what_next fields
+ , why_blocked = FFIClosures.tso_why_blocked fields
+ , flags = FFIClosures.tso_flags fields
+ , threadId = FFIClosures.tso_threadId fields
+ , saved_errno = FFIClosures.tso_saved_errno fields
+ , tso_dirty = FFIClosures.tso_dirty fields
+ , alloc_limit = FFIClosures.tso_alloc_limit fields
+ , tot_stack_size = FFIClosures.tso_tot_stack_size fields
+ , prof = FFIClosures.tso_prof fields
+ })
+ | otherwise
+ -> fail $ "Expected at least 6 ptr arguments to TSO, found "
+ ++ show (length pts)
+ STACK
+ | [] <- pts
+ -> withArray rawHeapWords (\ptr -> do
+ fields <- FFIClosures.peekStackFields ptr
+ pure $ StackClosure
+ { info = itbl
+ , stack_size = FFIClosures.stack_size fields
+ , stack_dirty = FFIClosures.stack_dirty fields
+#if __GLASGOW_HASKELL__ >= 811
+ , stack_marking = FFIClosures.stack_marking fields
+#endif
+ })
+ | otherwise
+ -> fail $ "Expected 0 ptr argument to STACK, found "
+ ++ show (length pts)
+
+ _ ->
+ pure $ UnsupportedClosure itbl
+
-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
getBoxedClosureData :: Box -> IO Closure
getBoxedClosureData (Box a) = getClosureData a
-
--- | Get the size of the top-level closure in words.
--- Includes header and payload. Does not follow pointers.
---
--- @since 8.10.1
-closureSize :: Box -> IO Int
-closureSize (Box x) = pure $ I# (closureSize# x)
-
-#if MIN_TOOL_VERSION_ghc(9,7,0)
--- TODO: Pattern match may move to function arguments
-stackFrameSize :: StackFrame -> Int
-stackFrameSize =
- \c ->
- case c of
- UpdateFrame {} -> sizeStgUpdateFrame
- CatchFrame {} -> sizeStgCatchFrame
- CatchStmFrame {} -> sizeStgCatchSTMFrame
- CatchRetryFrame {} -> sizeStgCatchRetryFrame
- AtomicallyFrame {} -> sizeStgAtomicallyFrame
- RetSmall {..} -> sizeStgClosure + length stack_payload
- RetBig {..} -> sizeStgClosure + length stack_payload
- RetFun {..} -> sizeStgRetFunFrame + length retFunPayload
- -- The one additional word is a pointer to the StgBCO in the closure's payload
- RetBCO {..} -> sizeStgClosure + 1 + length bcoArgs
- -- The one additional word is a pointer to the next stack chunk
- UnderflowFrame {} -> sizeStgClosure + 1
- _ -> error "Unexpected closure type"
-#endif
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -17,6 +17,7 @@ module GHC.Exts.Heap.Closures (
, TsoFlags(..)
, RetFunType(..)
, allClosures
+ , closureSize
-- * Stack
, StgStackClosure(..)
@@ -553,3 +554,10 @@ allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ Data.Foldable.toList weakLink
allClosures (OtherClosure {..}) = hvalues
allClosures _ = []
+
+-- | Get the size of the top-level closure in words.
+-- Includes header and payload. Does not follow pointers.
+--
+-- @since 8.10.1
+closureSize :: Box -> Int
+closureSize (Box x) = I# (closureSize# x)
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Decode.hs deleted
=====================================
@@ -1,243 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE UnliftedFFITypes #-}
-
-module GHC.Exts.Heap.Decode where
-import Prelude
-import GHC.Exts.Heap.Closures
-import GHC.Exts.Heap.ClosureTypes
-import GHC.Exts.Heap.Constants
-import GHC.Exts.Heap.ProfInfo.Types
-#if defined(PROFILING)
-import GHC.Exts.Heap.InfoTableProf
-#else
-import GHC.Exts.Heap.InfoTable
-#endif
-import GHC.Exts.Heap.Utils
-import qualified GHC.Exts.Heap.FFIClosures as FFIClosures
-import qualified GHC.Exts.Heap.ProfInfo.PeekProfInfo as PPI
-
-import Data.Bits
-import Foreign
-import GHC.Exts
-
--- | Convert an unpacked heap object, to a `GenClosure b`. The inputs to this
--- function can be generated from a heap object using `unpackClosure#`.
-getClosureDataFromHeapRep :: ByteArray# -> Ptr StgInfoTable -> [b] -> IO (GenClosure b)
-getClosureDataFromHeapRep heapRep infoTablePtr pts = do
- itbl <- peekItbl infoTablePtr
- getClosureDataFromHeapRepPrim (dataConNames infoTablePtr) PPI.peekTopCCS itbl heapRep pts
-
-getClosureDataFromHeapRepPrim
- :: IO (String, String, String)
- -- ^ A continuation used to decode the constructor description field,
- -- in ghc-debug this code can lead to segfaults because dataConNames
- -- will dereference a random part of memory.
- -> (Ptr a -> IO (Maybe CostCentreStack))
- -- ^ A continuation which is used to decode a cost centre stack
- -- In ghc-debug, this code will need to call back into the debuggee to
- -- fetch the representation of the CCS before decoding it. Using
- -- `peekTopCCS` for this argument can lead to segfaults in ghc-debug as
- -- the CCS argument will point outside the copied closure.
- -> StgInfoTable
- -- ^ The `StgInfoTable` of the closure, extracted from the heap
- -- representation.
- -> 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.
- -> [b]
- -- ^ Pointers in the payload of the closure, extracted from the heap
- -- representation as returned by `collect_pointers()` in `Heap.c`. The type
- -- `b` is some representation of a pointer e.g. `Any` or `Ptr Any`.
- -> IO (GenClosure b)
- -- ^ Heap representation of the closure.
-getClosureDataFromHeapRepPrim getConDesc decodeCCS itbl heapRep pts = do
- 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) <- getConDesc
- pure $ ConstrClosure itbl pts npts p m n
-
- t | t >= THUNK && t <= THUNK_STATIC -> do
- pure $ ThunkClosure itbl pts npts
-
- THUNK_SELECTOR -> case pts of
- [] -> fail "Expected at least 1 ptr argument to THUNK_SELECTOR"
- hd : _ -> pure $ SelectorClosure itbl hd
-
- t | t >= FUN && t <= FUN_STATIC -> do
- pure $ FunClosure itbl pts npts
-
- AP -> case pts of
- [] -> fail "Expected at least 1 ptr argument to AP"
- hd : tl -> case payloadWords of
- -- We expect at least the arity, n_args, and fun fields
- splitWord : _ : _ ->
- pure $ APClosure itbl
-#if defined(WORDS_BIGENDIAN)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
- (fromIntegral splitWord)
-#else
- (fromIntegral splitWord)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-#endif
- hd tl
- _ -> fail "Expected at least 2 raw words to AP"
-
- PAP -> case pts of
- [] -> fail "Expected at least 1 ptr argument to PAP"
- hd : tl -> case payloadWords of
- -- We expect at least the arity, n_args, and fun fields
- splitWord : _ : _ ->
- pure $ PAPClosure itbl
-#if defined(WORDS_BIGENDIAN)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
- (fromIntegral splitWord)
-#else
- (fromIntegral splitWord)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-#endif
- hd tl
- _ -> fail "Expected at least 2 raw words to PAP"
-
- AP_STACK -> case pts of
- [] -> fail "Expected at least 1 ptr argument to AP_STACK"
- hd : tl -> pure $ APStackClosure itbl hd tl
-
- IND -> case pts of
- [] -> fail "Expected at least 1 ptr argument to IND"
- hd : _ -> pure $ IndClosure itbl hd
-
- IND_STATIC -> case pts of
- [] -> fail "Expected at least 1 ptr argument to IND_STATIC"
- hd : _ -> pure $ IndClosure itbl hd
-
- BLACKHOLE -> case pts of
- [] -> fail "Expected at least 1 ptr argument to BLACKHOLE"
- hd : _ -> pure $ BlackholeClosure itbl hd
-
- BCO -> case pts of
- pts0 : pts1 : pts2 : _ -> case payloadWords of
- _ : _ : _ : splitWord : payloadRest ->
- pure $ BCOClosure itbl pts0 pts1 pts2
-#if defined(WORDS_BIGENDIAN)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
- (fromIntegral splitWord)
-#else
- (fromIntegral splitWord)
- (fromIntegral $ shiftR splitWord (wORD_SIZE_IN_BITS `div` 2))
-#endif
- payloadRest
- _ -> fail $ "Expected at least 4 words to BCO, found "
- ++ show (length payloadWords)
- _ -> fail $ "Expected at least 3 ptr argument to BCO, found "
- ++ show (length pts)
-
- ARR_WORDS -> case payloadWords of
- [] -> fail $ "Expected at least 1 words to ARR_WORDS, found "
- ++ show (length payloadWords)
- hd : tl -> pure $ ArrWordsClosure itbl hd tl
-
- t | t >= MUT_ARR_PTRS_CLEAN && t <= MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
- p0 : p1 : _ -> pure $ MutArrClosure itbl p0 p1 pts
- _ -> fail $ "Expected at least 2 words to MUT_ARR_PTRS_* "
- ++ "found " ++ show (length payloadWords)
-
- t | t >= SMALL_MUT_ARR_PTRS_CLEAN && t <= SMALL_MUT_ARR_PTRS_FROZEN_CLEAN -> case payloadWords of
- [] -> fail $ "Expected at least 1 word to SMALL_MUT_ARR_PTRS_* "
- ++ "found " ++ show (length payloadWords)
- hd : _ -> pure $ SmallMutArrClosure itbl hd pts
-
- t | t == MUT_VAR_CLEAN || t == MUT_VAR_DIRTY -> case pts of
- [] -> fail $ "Expected at least 1 words to MUT_VAR, found "
- ++ show (length pts)
- hd : _ -> pure $ MutVarClosure itbl hd
-
- t | t == MVAR_CLEAN || t == MVAR_DIRTY -> case pts of
- pts0 : pts1 : pts2 : _ -> pure $ MVarClosure itbl pts0 pts1 pts2
- _ -> fail $ "Expected at least 3 ptrs to MVAR, found "
- ++ show (length pts)
-
- BLOCKING_QUEUE ->
- pure $ OtherClosure itbl pts rawHeapWords
-
- WEAK -> case pts of
- pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure
- { info = itbl
- , cfinalizers = pts0
- , key = pts1
- , value = pts2
- , finalizer = pts3
- , weakLink = case rest of
- [] -> Nothing
- [p] -> Just p
- _ -> error $ "Expected 4 or 5 words in WEAK, but found more: " ++ show (length pts)
- }
- _ -> error $ "Expected 4 or 5 words in WEAK, but found less: " ++ show (length pts)
- TSO | ( u_lnk : u_gbl_lnk : tso_stack : u_trec : u_blk_ex : u_bq : other) <- pts
- -> withArray rawHeapWords (\ptr -> do
- fields <- FFIClosures.peekTSOFields decodeCCS ptr
- pure $ TSOClosure
- { info = itbl
- , link = u_lnk
- , global_link = u_gbl_lnk
- , tsoStack = tso_stack
- , trec = u_trec
- , blocked_exceptions = u_blk_ex
- , bq = u_bq
- , thread_label = case other of
- [tl] -> Just tl
- [] -> Nothing
- _ -> error $ "thead_label:Expected 0 or 1 extra arguments"
- , what_next = FFIClosures.tso_what_next fields
- , why_blocked = FFIClosures.tso_why_blocked fields
- , flags = FFIClosures.tso_flags fields
- , threadId = FFIClosures.tso_threadId fields
- , saved_errno = FFIClosures.tso_saved_errno fields
- , tso_dirty = FFIClosures.tso_dirty fields
- , alloc_limit = FFIClosures.tso_alloc_limit fields
- , tot_stack_size = FFIClosures.tso_tot_stack_size fields
- , prof = FFIClosures.tso_prof fields
- })
- | otherwise
- -> fail $ "Expected at least 6 ptr arguments to TSO, found "
- ++ show (length pts)
- STACK
- | [] <- pts
- -> withArray rawHeapWords (\ptr -> do
- fields <- FFIClosures.peekStackFields ptr
- pure $ StackClosure
- { info = itbl
- , stack_size = FFIClosures.stack_size fields
- , stack_dirty = FFIClosures.stack_dirty fields
-#if __GLASGOW_HASKELL__ >= 811
- , stack_marking = FFIClosures.stack_marking fields
-#endif
- })
- | otherwise
- -> fail $ "Expected 0 ptr argument to STACK, found "
- ++ show (length pts)
-
- _ ->
- pure $ UnsupportedClosure itbl
=====================================
libraries/ghc-heap/GHC/Exts/Stack.hs
=====================================
@@ -0,0 +1,35 @@
+{-# LANGUAGE CPP #-}
+#if MIN_TOOL_VERSION_ghc(9,7,0)
+{-# LANGUAGE RecordWildCards #-}
+module GHC.Exts.Stack (
+ -- * Stack inspection
+ decodeStack
+ , stackFrameSize
+ )
+where
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Stack.Decode
+import GHC.Exts.Stack.Constants
+import Prelude
+
+-- TODO: Pattern match may move to function arguments
+stackFrameSize :: StackFrame -> Int
+stackFrameSize =
+ \c ->
+ case c of
+ UpdateFrame {} -> sizeStgUpdateFrame
+ CatchFrame {} -> sizeStgCatchFrame
+ CatchStmFrame {} -> sizeStgCatchSTMFrame
+ CatchRetryFrame {} -> sizeStgCatchRetryFrame
+ AtomicallyFrame {} -> sizeStgAtomicallyFrame
+ RetSmall {..} -> sizeStgClosure + length stack_payload
+ RetBig {..} -> sizeStgClosure + length stack_payload
+ RetFun {..} -> sizeStgRetFunFrame + length retFunPayload
+ -- The one additional word is a pointer to the StgBCO in the closure's payload
+ RetBCO {..} -> sizeStgClosure + 1 + length bcoArgs
+ -- The one additional word is a pointer to the next stack chunk
+ UnderflowFrame {} -> sizeStgClosure + 1
+ _ -> error "Unexpected closure type"
+#else
+module GHC.Exts.Stack where
+#endif
=====================================
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
=====================================
@@ -23,9 +23,9 @@ import Data.Maybe
import Foreign
import GHC.Exts
import GHC.Exts.Heap.ClosureTypes
-import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.Closures (Box(..), RetFunType(..), Closure, GenClosure(UnknownTypeWordSizedPrimitive), StackFrame(..), StgStackClosure(..))
import GHC.Exts.Heap.Constants (wORD_SIZE_IN_BITS)
-import GHC.Exts.Heap.Decode
+import GHC.Exts.Heap
import GHC.Exts.Heap.InfoTable
import GHC.Exts.Stack.Constants
import GHC.IO (IO (..))
@@ -296,8 +296,6 @@ decodeBitmaps stackSnapshot# index bitmapWords size =
getIndex (SfiClosure _ i) = i
getIndex (SfiPrimitive _ i) = i
--- TODO: (auto-) format the code
--- TODO: Check all functions with two WordOffsets? Can't it be one?
decodeSmallBitmap :: SmallBitmapGetter -> StackSnapshot# -> WordOffset -> WordOffset -> IO [Closure]
decodeSmallBitmap getterFun# stackSnapshot# index relativePayloadOffset =
do
@@ -411,32 +409,6 @@ unpackStackFrame (StackSnapshot stackSnapshot#, index) = do
}
x -> error $ "Unexpected closure type on stack: " ++ show x
--- TODO: Duplicate
-getClosureDataFromHeapObject ::
- -- | Heap object to decode.
- a ->
- -- | Heap representation of the closure.
- IO Closure
-getClosureDataFromHeapObject x = do
- case unpackClosure# x of
- (# infoTableAddr, heapRep, pointersArray #) -> do
- 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 heapRep infoTablePtr ptrList
-
--- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
-getBoxedClosureData :: Box -> IO Closure
-getBoxedClosureData (Box a) = getClosureDataFromHeapObject a
-
-- | Unbox 'Int#' from 'Int'
toInt# :: Int -> Int#
toInt# (I# i) = i
@@ -482,5 +454,4 @@ decodeStack (StackSnapshot stack#) = do
#else
module GHC.Exts.Stack.Decode where
-import GHC.Base (IO)
#endif
=====================================
libraries/ghc-heap/ghc-heap.cabal.in
=====================================
@@ -39,7 +39,6 @@ library
GHC.Exts.Heap.Closures
GHC.Exts.Heap.ClosureTypes
GHC.Exts.Heap.Constants
- GHC.Exts.Heap.Decode
GHC.Exts.Heap.InfoTable
GHC.Exts.Heap.InfoTable.Types
GHC.Exts.Heap.InfoTableProf
@@ -52,4 +51,5 @@ library
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled
GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled
GHC.Exts.Stack.Constants
+ GHC.Exts.Stack
GHC.Exts.Stack.Decode
=====================================
libraries/ghc-heap/tests/ClosureSizeUtils.hs
=====================================
@@ -11,7 +11,6 @@ module ClosureSizeUtils (assertSize, assertSizeUnlifted) where
import Control.Monad
import GHC.Exts
-import GHC.Exts.Heap
import GHC.Exts.Heap.Closures
import GHC.Stack
import Type.Reflection
@@ -46,7 +45,7 @@ assertSizeBox
-> Int -- ^ expected size in words
-> IO ()
assertSizeBox x ty expected = do
- !size <- closureSize x
+ let !size = closureSize x
when (size /= expected') $ do
putStrLn $ "closureSize ("++show ty++") == "++show size++", expected "++show expected'
putStrLn $ prettyCallStack callStack
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -17,6 +17,7 @@ import Debug.Trace
import GHC.Exts
import GHC.Exts.Heap
import GHC.Exts.Heap.Closures
+import GHC.Exts.Stack
import GHC.Exts.Stack.Decode
import GHC.IO (IO (..))
import GHC.Stack (HasCallStack)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75c42867294427feb3c430151d1619600f19cb0c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/75c42867294427feb3c430151d1619600f19cb0c
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/20230409/859f06aa/attachment-0001.html>
More information about the ghc-commits
mailing list