[Git][ghc/ghc][wip/decode_cloned_stack] Cleanup
Sven Tennie (@supersven)
gitlab at gitlab.haskell.org
Sat Feb 25 15:23:43 UTC 2023
Sven Tennie pushed to branch wip/decode_cloned_stack at Glasgow Haskell Compiler / GHC
Commits:
b7dfa91d by Sven Tennie at 2023-02-25T15:22:56+00:00
Cleanup
- - - - -
7 changed files:
- libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
- libraries/ghc-heap/tests/stack_big_ret.hs
- libraries/ghc-heap/tests/stack_misc_closures.hs
- libraries/ghc-heap/tests/stack_misc_closures_c.c
- libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
- libraries/ghc-heap/tests/stack_stm_frames.hs
- libraries/ghc-heap/tests/stack_underflow.hs
Changes:
=====================================
libraries/ghc-heap/GHC/Exts/Stack/Decode.hs
=====================================
@@ -457,5 +457,4 @@ decodeStack' s =
#else
module GHC.Exts.Stack.Decode where
-import GHC.Data.UnionFind (equivalent)
#endif
=====================================
libraries/ghc-heap/tests/stack_big_ret.hs
=====================================
@@ -8,17 +8,17 @@ import Control.Concurrent
import Data.IORef
import Data.Maybe
import GHC.Exts (StackSnapshot#)
-import GHC.Exts.Stack.Decode
+import GHC.Exts.Heap
import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.InfoTable.Types
+import GHC.Exts.Stack.Decode
import GHC.IO.Unsafe
import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack
import System.IO (hPutStrLn, stderr)
import System.Mem
import TestUtils
-import GHC.Exts.Heap
cloneStackReturnInt :: IORef (Maybe StackSnapshot) -> Int
cloneStackReturnInt ioRef = unsafePerformIO $ do
@@ -46,7 +46,7 @@ main = do
(== 1)
(length $ filter isBigReturnFrame stackFrames)
cs <- (mapM unbox . payload . head) $ filter isBigReturnFrame stackFrames
- let xs = zip [1 ..] cs
+ let xs = zip [1 ..] cs
mapM_ (uncurry checkArg) xs
checkArg :: Word -> Closure -> IO ()
=====================================
libraries/ghc-heap/tests/stack_misc_closures.hs
=====================================
@@ -15,16 +15,16 @@ module Main where
import Data.Functor
import Debug.Trace
import GHC.Exts
-import GHC.Exts.Stack.Decode
import GHC.Exts.Heap
import GHC.Exts.Heap.Closures
+import GHC.Exts.Stack.Decode
import GHC.IO (IO (..))
import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack (StackSnapshot (..))
+import System.Info
import System.Mem
import TestUtils
import Unsafe.Coerce (unsafeCoerce)
-import System.Info
foreign import prim "any_update_framezh" any_update_frame# :: SetupFunction
@@ -67,9 +67,8 @@ foreign import ccall "bitsInWord" bitsInWord :: Word
{- Test stategy
~~~~~~~~~~~~
-- Create @StgStack at s in C that contain two closures (as they are on stack they
-may also be called "frames"). A stop frame and the frame which's decoding should
-be tested.
+- Create @StgStack at s in C that contain two frames: A stop frame and the frame
+which's decoding should be tested.
- Cmm primops are used to get `StackSnapshot#` values. (This detour ensures that
the closures are referenced by `StackSnapshot#` and not garbage collected right
@@ -80,10 +79,10 @@ away.)
This strategy may look pretty complex for a test. But, it can provide very
specific corner cases that would be hard to (reliably!) produce in Haskell.
-N.B. `StackSnapshots` are managed by the garbage collector. This isn't much of
-an issue regarding the test data, as it's already very terse. However, it's
-important to know that the GC may rewrite parts of the stack and that the stack
-must be sound (otherwise, the GC may fail badly.)
+N.B. `StackSnapshots` are managed by the garbage collector. It's important to
+know that the GC may rewrite parts of the stack and that the stack must be sound
+(otherwise, the GC may fail badly.) To find subtle garbage collection related
+bugs, the GC is triggered several times.
The decission to make `StackSnapshots`s (and their closures) being managed by the
GC isn't accidential. It's closer to the reality of decoding stacks.
@@ -104,9 +103,9 @@ main = do
assertEqual (tipe info) UPDATE_FRAME
assertEqual 1 =<< (getWordFromBlackhole =<< getBoxedClosureData updatee)
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 2"
+ traceM "Test 2"
testSize any_update_frame# 2
- traceM "Test 3"
+ traceM "Test 3"
test any_catch_frame# $
\case
CatchFrame {..} -> do
@@ -114,9 +113,9 @@ main = do
assertEqual exceptions_blocked 1
assertConstrClosure 1 =<< getBoxedClosureData handler
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 4"
+ traceM "Test 4"
testSize any_catch_frame# 3
- traceM "Test 5"
+ traceM "Test 5"
test any_catch_stm_frame# $
\case
CatchStmFrame {..} -> do
@@ -124,9 +123,9 @@ main = do
assertConstrClosure 1 =<< getBoxedClosureData catchFrameCode
assertConstrClosure 2 =<< getBoxedClosureData handler
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 6"
+ traceM "Test 6"
testSize any_catch_stm_frame# 3
- traceM "Test 7"
+ traceM "Test 7"
test any_catch_retry_frame# $
\case
CatchRetryFrame {..} -> do
@@ -135,9 +134,9 @@ main = do
assertConstrClosure 2 =<< getBoxedClosureData first_code
assertConstrClosure 3 =<< getBoxedClosureData alt_code
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 8"
+ traceM "Test 8"
testSize any_catch_retry_frame# 4
- traceM "Test 9"
+ traceM "Test 9"
test any_atomically_frame# $
\case
AtomicallyFrame {..} -> do
@@ -145,9 +144,9 @@ main = do
assertConstrClosure 1 =<< getBoxedClosureData atomicallyFrameCode
assertConstrClosure 2 =<< getBoxedClosureData result
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 10"
+ traceM "Test 10"
testSize any_atomically_frame# 3
- traceM "Test 11"
+ traceM "Test 11"
test any_ret_small_prim_frame# $
\case
RetSmall {..} -> do
@@ -156,9 +155,9 @@ main = do
assertEqual (length pCs) 1
assertUnknownTypeWordSizedPrimitive 1 (head pCs)
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 12"
+ traceM "Test 12"
testSize any_ret_small_prim_frame# 2
- traceM "Test 13"
+ traceM "Test 13"
test any_ret_small_closure_frame# $
\case
RetSmall {..} -> do
@@ -167,9 +166,9 @@ main = do
assertEqual (length pCs) 1
assertConstrClosure 1 (head pCs)
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 14"
+ traceM "Test 14"
testSize any_ret_small_closure_frame# 2
- traceM "Test 15"
+ traceM "Test 15"
test any_ret_small_closures_frame# $
\case
RetSmall {..} -> do
@@ -179,9 +178,9 @@ main = do
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. maxSmallBitmapBits]
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 16"
+ traceM "Test 16"
testSize any_ret_small_closures_frame# (1 + fromIntegral maxSmallBitmapBits_c)
- traceM "Test 17"
+ traceM "Test 17"
test any_ret_small_prims_frame# $
\case
RetSmall {..} -> do
@@ -191,9 +190,9 @@ main = do
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
assertEqual wds [1 .. maxSmallBitmapBits]
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 18"
+ traceM "Test 18"
testSize any_ret_small_prims_frame# (1 + fromIntegral maxSmallBitmapBits_c)
- traceM "Test 19"
+ traceM "Test 19"
test any_ret_big_prims_min_frame# $
\case
RetBig {..} -> do
@@ -203,9 +202,9 @@ main = do
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
assertEqual wds [1 .. minBigBitmapBits]
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 20"
+ traceM "Test 20"
testSize any_ret_big_prims_min_frame# (minBigBitmapBits + 1)
- traceM "Test 21"
+ traceM "Test 21"
test any_ret_big_closures_min_frame# $
\case
RetBig {..} -> do
@@ -215,9 +214,9 @@ main = do
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. minBigBitmapBits]
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 22"
+ traceM "Test 22"
testSize any_ret_big_closures_min_frame# (minBigBitmapBits + 1)
- traceM "Test 23"
+ traceM "Test 23"
test any_ret_big_closures_two_words_frame# $
\case
RetBig {..} -> do
@@ -228,9 +227,9 @@ main = do
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. (fromIntegral closureCount)]
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 24"
+ traceM "Test 24"
testSize any_ret_big_closures_two_words_frame# (fromIntegral bitsInWord + 1 + 1)
- traceM "Test 25"
+ traceM "Test 25"
test any_ret_fun_arg_n_prim_frame# $
\case
RetFun {..} -> do
@@ -243,7 +242,7 @@ main = do
let wds = map getWordFromUnknownTypeWordSizedPrimitive pCs
assertEqual wds [1]
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 26"
+ traceM "Test 26"
test any_ret_fun_arg_gen_frame# $
\case
RetFun {..} -> do
@@ -264,9 +263,9 @@ main = do
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. 9]
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 27"
+ traceM "Test 27"
testSize any_ret_fun_arg_gen_frame# (3 + 9)
- traceM "Test 28"
+ traceM "Test 28"
test any_ret_fun_arg_gen_big_frame# $
\case
RetFun {..} -> do
@@ -284,9 +283,9 @@ main = do
assertEqual (length pCs) 59
let wds = map getWordFromConstr01 pCs
assertEqual wds [1 .. 59]
- traceM "Test 29"
+ traceM "Test 29"
testSize any_ret_fun_arg_gen_big_frame# (3 + 59)
- traceM "Test 30"
+ traceM "Test 30"
test any_bco_frame# $
\case
RetBCO {..} -> do
@@ -300,6 +299,7 @@ main = do
BCOClosure {..} -> do
assertEqual (tipe info) BCO
assertEqual arity 3
+ assertEqual size 7
assertArrWordsClosure [1] =<< getBoxedClosureData instrs
assertArrWordsClosure [2] =<< getBoxedClosureData literals
assertMutArrClosure [3] =<< getBoxedClosureData bcoptrs
@@ -310,9 +310,9 @@ main = do
bitmap
e -> error $ "Wrong closure type: " ++ show e
e -> error $ "Wrong closure type: " ++ show e
- traceM "Test 31"
+ traceM "Test 31"
testSize any_bco_frame# 3
- traceM "Test 32"
+ traceM "Test 32"
test any_underflow_frame# $
\case
UnderflowFrame {..} -> do
=====================================
libraries/ghc-heap/tests/stack_misc_closures_c.c
=====================================
@@ -1,14 +1,4 @@
-#include "MachDeps.h"
#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 "rts/storage/InfoTables.h"
-#include "rts/storage/TSO.h"
-#include "stg/MiscClosures.h"
-#include "stg/Types.h"
// See rts/Threads.c
#define MIN_STACK_WORDS (RESERVED_STACK_WORDS + sizeofW(StgStopFrame) + 3)
@@ -43,8 +33,8 @@ void create_any_catch_stm_frame(Capability *cap, StgStack *stack, StgWord w) {
StgCatchSTMFrame *catchF = (StgCatchSTMFrame *)stack->sp;
SET_HDR(catchF, &stg_catch_stm_frame_info, CCS_SYSTEM);
StgClosure *payload1 = rts_mkWord(cap, w);
- StgClosure *payload2 = rts_mkWord(cap, w + 1);
catchF->code = payload1;
+ StgClosure *payload2 = rts_mkWord(cap, w + 1);
catchF->handler = payload2;
}
@@ -62,8 +52,8 @@ void create_any_atomically_frame(Capability *cap, StgStack *stack, StgWord w) {
StgAtomicallyFrame *aF = (StgAtomicallyFrame *)stack->sp;
SET_HDR(aF, &stg_atomically_frame_info, CCS_SYSTEM);
StgClosure *payload1 = rts_mkWord(cap, w);
- StgClosure *payload2 = rts_mkWord(cap, w + 1);
aF->code = payload1;
+ StgClosure *payload2 = rts_mkWord(cap, w + 1);
aF->result = payload2;
}
@@ -248,7 +238,8 @@ void create_any_underflow_frame(Capability *cap, StgStack *stack, StgWord w) {
underflowF->next_chunk = any_ret_small_prim_frame(cap);
}
-// Import from Sanity.c
+// Import from Sanity.c - This implies that the test must be run with debug RTS
+// only!
extern void checkSTACK(StgStack *stack);
// Basically, a stripped down version of createThread() (regarding stack
=====================================
libraries/ghc-heap/tests/stack_misc_closures_prim.cmm
=====================================
@@ -2,7 +2,7 @@
any_update_framezh() {
P_ stack;
- ("ptr" stack) = ccall any_update_frame(MyCapability() "ptr");
+ (stack) = ccall any_update_frame(MyCapability() "ptr");
return (stack);
}
@@ -182,7 +182,7 @@ P_ p51, P_ p52, P_ p53, P_ p54, P_ p55, P_ p56, P_ p57, P_ p58, P_ p59
return ();
}
-// Size of this large bitmap closure is: max size of bits in word + 1
+// Size of this large bitmap closure is: max size of bits in machine word + 1.
// This results in a two word StgLargeBitmap.
INFO_TABLE_RET ( test_big_ret_two_words_p, RET_BIG, W_ info_ptr,
#if SIZEOF_VOID_P == 4
@@ -206,7 +206,7 @@ P_ p61, P_ p62, P_ p63, P_ p64, P_ p65
}
// A BLACKHOLE without any code. Just a placeholder to keep the GC happy.
-INFO_TABLE(test_fake_blackhole,1,0,BLACKHOLE,"BLACKHOLE","BLACKHOLE")
+INFO_TABLE( test_fake_blackhole, 1, 0, BLACKHOLE, "BLACKHOLE", "BLACKHOLE")
(P_ node)
{
return ();
=====================================
libraries/ghc-heap/tests/stack_stm_frames.hs
=====================================
@@ -5,13 +5,13 @@ module Main where
import Control.Concurrent.STM
import Control.Exception
import GHC.Conc
-import GHC.Exts.Stack.Decode
+import GHC.Exts.Heap
import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.InfoTable.Types
+import GHC.Exts.Stack.Decode
import GHC.Stack.CloneStack
import TestUtils
-import GHC.Exts.Heap
main :: IO ()
main = do
=====================================
libraries/ghc-heap/tests/stack_underflow.hs
=====================================
@@ -2,12 +2,13 @@
module Main where
+import Control.Monad
import Data.Bool (Bool (True))
-import GHC.Exts.Stack.Decode
import GHC.Exts.Heap
import GHC.Exts.Heap.ClosureTypes
import GHC.Exts.Heap.Closures
import GHC.Exts.Heap.InfoTable.Types
+import GHC.Exts.Stack.Decode
import GHC.Stack (HasCallStack)
import GHC.Stack.CloneStack
import TestUtils
@@ -15,14 +16,12 @@ import TestUtils
main = loop 128
{-# NOINLINE loop #-}
-loop 0 = () <$ getStack
+loop 0 = Control.Monad.void getStack
loop n = print "x" >> loop (n - 1) >> print "x"
getStack :: HasCallStack => IO ()
getStack = do
(s, decodedStack) <- getDecodedStack
- -- Uncomment to see the frames (for debugging purposes)
- -- hPutStrLn stderr $ "Stack frames : " ++ show decodedStack
assertStackInvariants s decodedStack
assertThat
"Stack contains underflow frames"
@@ -39,7 +38,7 @@ assertStackChunksAreDecodable s = do
let underflowFrames = filter isUnderflowFrame s
stackClosures <- mapM (getBoxedClosureData . nextChunk) underflowFrames
let stackBoxes = map stack stackClosures
- framesOfChunks <- sequence (map (mapM getBoxedClosureData) stackBoxes)
+ framesOfChunks <- mapM (mapM getBoxedClosureData) stackBoxes
assertThat
"No empty stack chunks"
(== True)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b7dfa91d32a4333860520cd8fc3f1d3173dc3fa3
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b7dfa91d32a4333860520cd8fc3f1d3173dc3fa3
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/20230225/912c7d63/attachment-0001.html>
More information about the ghc-commits
mailing list