[Git][ghc/ghc][wip/decode_cloned_stack] Do not decode values twice: Introduce DecodedClosureBox
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sun Dec 25 17:36:23 UTC 2022
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
ef13fd24 by Sven Tennie at 2022-12-25T17:35:44+00:00
Do not decode values twice: Introduce DecodedClosureBox
- - - - -
9 changed files:
- libraries/ghc-heap/GHC/Exts/DecodeStack.hs
- libraries/ghc-heap/GHC/Exts/Heap.hs
- libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
- libraries/ghc-heap/tests/TestUtils.hs
- libraries/ghc-heap/tests/all.T
- − libraries/ghc-heap/tests/stack_misc_closures.c
- libraries/ghc-heap/tests/stack_misc_closures.hs
- rts/Heap.c
- rts/PrimOps.cmm
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/DecodeStack.hs
=====================================
@@ -115,15 +115,14 @@ getClosure sfi relativeOffset = toClosure (unpackClosureReferencedByFrame# (intT
toClosure :: (StackSnapshot# -> Word# -> (# Addr#, ByteArray#, Array# Any #)) -> StackFrameIter -> IO Box
toClosure f# (StackFrameIter (# s#, i# #)) =
case f# s# i# of
- (# infoTableAddr, heapRep, pointersArray #) -> do
+ (# infoTableAddr, heapRep, pointersArray #) ->
let infoTablePtr = Ptr infoTableAddr
ptrList = [case indexArray# pointersArray i of
(# ptr #) -> CL.Box ptr
| I# i <- [0..I# (sizeofArray# pointersArray) - 1]
]
-
- c <- (getClosureDataFromHeapRep heapRep infoTablePtr ptrList)
- pure $ asBox c
+ in
+ DecodedClosureBox <$> (getClosureDataFromHeapRep heapRep infoTablePtr ptrList)
-- TODO: Make function more readable: No IO in let bindings
decodeLargeBitmap :: (StackSnapshot# -> Word# -> (# ByteArray#, Word# #)) -> StackFrameIter -> Word# -> IO [Box]
@@ -189,8 +188,9 @@ unpackStackFrameIter sfi@(StackFrameIter (# s#, i# #)) = trace ("decoding ... "
-- TODO: Decode update frame type
UPDATE_FRAME -> let
!t = (toEnum . fromInteger . toInteger) (W# (getUpdateFrameType# s# i#))
- in
- CL.UpdateFrame t <$> getClosure sfi offsetStgUpdateFrameUpdatee
+ c = getClosure sfi offsetStgUpdateFrameUpdatee
+ in
+ (CL.UpdateFrame t ) <$> c
CATCH_FRAME -> do
-- TODO: Replace with getWord# expression
let exceptionsBlocked = W# (getCatchFrameExceptionsBlocked# s# i#)
=====================================
libraries/ghc-heap/GHC/Exts/Heap.hs
=====================================
@@ -174,3 +174,6 @@ getClosureDataFromHeapObject x = do
-- | Like 'getClosureData', but taking a 'Box', so it is easier to work with.
getBoxedClosureData :: Box -> IO Closure
getBoxedClosureData (Box a) = getClosureData a
+#if MIN_VERSION_base(4,17,0)
+getBoxedClosureData (DecodedClosureBox a) = pure a
+#endif
=====================================
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs
=====================================
@@ -20,7 +20,6 @@ module GHC.Exts.Heap.Closures (
, RetFunType(..)
, allClosures
, closureSize
- , RetFunType(..)
-- * Boxes
, Box(..)
@@ -68,7 +67,13 @@ foreign import prim "reallyUnsafePtrEqualityUpToTag"
-- unevaluated thunks can safely be moved around inside the Box, and when
-- required, e.g. in 'getBoxedClosureData', the function knows how far it has
-- to evaluate the argument.
+#if MIN_VERSION_base(4,17,0)
+data Box = Box Any | DecodedClosureBox Closure
+
+
+#else
data Box = Box Any
+#endif
instance Show Box where
-- From libraries/base/GHC/Ptr.lhs
@@ -80,6 +85,21 @@ instance Show Box where
tag = ptr .&. fromIntegral tAG_MASK -- ((1 `shiftL` TAG_BITS) -1)
addr = ptr - tag
pad_out ls = '0':'x':ls
+#if MIN_VERSION_base(4,17,0)
+ showsPrec _ (DecodedClosureBox a) rs = "(DecodedClosureBox " ++ show a ++ ")" ++ rs
+#endif
+
+-- | Boxes can be compared, but this is not pure, as different heap objects can,
+-- after garbage collection, become the same object.
+areBoxesEqual :: Box -> Box -> IO Bool
+areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
+ 0# -> pure False
+ _ -> pure True
+#if MIN_VERSION_base(4,17,0)
+-- TODO: Implement
+areBoxesEqual (DecodedClosureBox a) (DecodedClosureBox b) = error "Not implemented, yet!"
+areBoxesEqual _ _ = pure $ False
+#endif
-- |This takes an arbitrary value and puts it into a box.
-- Note that calls like
@@ -93,14 +113,6 @@ instance Show Box where
asBox :: a -> Box
asBox x = Box (unsafeCoerce# x)
--- | Boxes can be compared, but this is not pure, as different heap objects can,
--- after garbage collection, become the same object.
-areBoxesEqual :: Box -> Box -> IO Bool
-areBoxesEqual (Box a) (Box b) = case reallyUnsafePtrEqualityUpToTag# a b of
- 0# -> pure False
- _ -> pure True
-
-
------------------------------------------------------------------------
-- Closures
@@ -540,7 +552,6 @@ data TsoFlags
| TsoFlagsUnknownValue Word32 -- ^ Please report this as a bug
deriving (Eq, Show, Generic, Ord)
--- TODO: Fix this to include stack frames
-- | For generic code, this function returns all referenced closures.
allClosures :: GenClosure b -> [b]
allClosures (ConstrClosure {..}) = ptrArgs
@@ -562,6 +573,18 @@ allClosures (FunClosure {..}) = ptrArgs
allClosures (BlockingQueueClosure {..}) = [link, blackHole, owner, queue]
allClosures (WeakClosure {..}) = [cfinalizers, key, value, finalizer] ++ Data.Foldable.toList weakLink
allClosures (OtherClosure {..}) = hvalues
+#if MIN_VERSION_base(4,17,0)
+allClosures (SimpleStack {..}) = stackClosures
+allClosures (UpdateFrame {..}) = [updatee]
+allClosures (CatchFrame {..}) = [handler]
+allClosures (CatchStmFrame {..}) = [catchFrameCode, handler]
+allClosures (CatchRetryFrame {..}) = [first_code, alt_code]
+allClosures (AtomicallyFrame {..}) = [atomicallyFrameCode, result]
+allClosures (RetSmall {..}) = payload
+allClosures (RetBig {..}) = payload
+allClosures (RetFun {..}) = retFunFun : retFunPayload
+allClosures (RetBCO {..}) = bcoInstrs : bcoLiterals : bcoPtrs : bcoPayload
+#endif
allClosures _ = []
-- | Get the size of the top-level closure in words.
@@ -570,3 +593,8 @@ allClosures _ = []
-- @since 8.10.1
closureSize :: Box -> Int
closureSize (Box x) = I# (closureSize# x)
+#if MIN_VERSION_base(4,17,0)
+-- TODO: Add comment to explain. This is a bit weird because it returns the size
+-- of the representation, not the closure itself.
+closureSize (DecodedClosureBox dc) = closureSize $ asBox dc
+#endif
=====================================
libraries/ghc-heap/tests/TestUtils.hs
=====================================
@@ -140,3 +140,4 @@ stackFrameToClosureTypes = getClosureTypes
unbox :: Box -> Closure
unbox (Box c) = unsafeCoerce c
+unbox (DecodedClosureBox c) = c
=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -94,3 +94,19 @@ test('stack_stm_frames',
],
multi_compile_and_run,
['stack_stm_frames', [('stack_lib.c','')], '-debug -optc-g -g'])
+
+# TODO: Remove debug flags
+test('stack_misc_closures',
+ [
+ extra_files(['stack_misc_closures_c.c', 'stack_misc_closures_prim.cmm','stack_lib.c', 'TestUtils.hs']),
+ ignore_stdout,
+ ignore_stderr
+ ],
+ multi_compile_and_run,
+ ['stack_misc_closures',
+ [ ('stack_misc_closures_c.c', '')
+ ,('stack_misc_closures_prim.cmm', '')
+ ,('stack_lib.c', '')
+ ]
+ , '-debug -optc-g -g'
+ ])
=====================================
libraries/ghc-heap/tests/stack_misc_closures.c deleted
=====================================
@@ -1,20 +0,0 @@
-#include "Rts.h"
-#include "RtsAPI.h"
-#include "rts/Messages.h"
-#include "rts/Types.h"
-#include "rts/storage/ClosureMacros.h"
-#include "rts/storage/Closures.h"
-#include "stg/Types.h"
-#include <stdlib.h>
-
-StgStack *update_frame() {
- Capability *cap = rts_lock();
- StgWord closureSizeBytes = sizeof(StgStack) + sizeof(StgStopFrame) + sizeof(StgUpdateFrame);
- StgStack *stack = (StgStack*) allocate(cap, ROUNDUP_BYTES_TO_WDS(closureSizeBytes));
- SET_HDR(stack, &, CCS_SYSTEM);
- stack->stack_size = closureSizeBytes;
- stack->dirty = 0;
- stack->marking = 0;
- rts_unlock(cap);
- return stack;
-}
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -0,0 +1,55 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedDatatypes #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module Main where
+
+import GHC.Exts
+import GHC.Exts.DecodeStack
+import GHC.Exts.Heap
+import GHC.Exts.Heap.Closures
+import GHC.Stack.CloneStack (StackSnapshot (..))
+import TestUtils
+import Unsafe.Coerce (unsafeCoerce)
+import GHC.Stack (HasCallStack)
+
+foreign import prim "any_update_framezh" any_update_frame# :: Word# -> (# StackSnapshot# #)
+
+main :: HasCallStack => IO ()
+main = do
+ let sn = StackSnapshot (unboxSingletonTuple (any_update_frame# 42##))
+ stack <- decodeStack' sn
+ assertStackInvariants sn stack
+ assertEqual (length stack) 2
+
+ let updateFrame = head stack
+ print $ "updateFrame : " ++ show updateFrame
+ case updateFrame of
+ UpdateFrame {..} -> do
+ assertEqual knownUpdateFrameType NormalUpdateFrame
+ u <- getBoxedClosureData updatee
+ case u of
+ ConstrClosure {..} -> do
+ assertEqual (tipe info) CONSTR_0_1
+ assertEqual dataArgs [42]
+ assertEqual (null ptrArgs) True
+ _ -> error $ "Wrong closure type: " ++ show u
+ _ -> error $ "Wrong closure type: " ++ show updateFrame
+ assertThat
+ "Last frame is stop frame"
+ ( \case
+ StopFrame -> True
+ _ -> False
+ )
+ (last stack)
+
+unboxSingletonTuple :: (# StackSnapshot# #) -> StackSnapshot#
+unboxSingletonTuple (# s# #) = s#
=====================================
rts/Heap.c
=====================================
@@ -12,6 +12,7 @@
#include "Capability.h"
#include "Printer.h"
+#include "rts/storage/InfoTables.h"
StgWord heap_view_closureSize(StgClosure *closure) {
ASSERT(LOOKS_LIKE_CLOSURE_PTR(closure));
@@ -283,3 +284,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
return arr;
}
+
+const StgInfoTable* getInfo(StgClosure* c) {
+ return get_itbl(c);
+}
=====================================
rts/PrimOps.cmm
=====================================
@@ -2510,7 +2510,7 @@ stg_unpackClosurezh ( P_ closure )
{
W_ info, ptrs, nptrs, p, ptrs_arr, dat_arr;
MAYBE_GC_P(stg_unpackClosurezh, closure);
- info = %GET_STD_INFO(UNTAG(closure));
+ (info) = ccall getInfo(UNTAG(closure));
prim_read_barrier;
ptrs = TO_W_(%INFO_PTRS(info));
@@ -2518,7 +2518,6 @@ stg_unpackClosurezh ( P_ closure )
W_ clos;
clos = UNTAG(closure);
-
W_ len;
// The array returned, dat_arr, is the raw data for the entire closure.
// The length is variable based upon the closure type, ptrs, and non-ptrs
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef13fd244b94578b854faa65fac05f0f39e04f32
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/ef13fd244b94578b854faa65fac05f0f39e04f32
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/20221225/f3d9d1c9/attachment-0001.html>
More information about the ghc-commits
mailing list