[Git][ghc/ghc][wip/ghc-debug] Add assertions to list_threads_and_misc_roots test

[Sven Tennie]

Sven Tennie pushed to branch wip/ghc-debug at Glasgow Haskell Compiler / GHC


Commits:
237e4082 by Sven Tennie at 2020-06-28T12:45:12+02:00
Add assertions to list_threads_and_misc_roots test

- - - - -


3 changed files:

- libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
- libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
- libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c


Changes:

=====================================
libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs
=====================================
@@ -81,7 +81,7 @@ data ClosureType
     | SMALL_MUT_ARR_PTRS_FROZEN_CLEAN
     | COMPACT_NFDATA
     | N_CLOSURE_TYPES
- deriving (Enum, Eq, Ord, Show, Generic)
+ deriving (Enum, Eq, Ord, Show, Generic, Bounded)
 
 -- | Return the size of the closures header in words
 closureTypeHeaderSize :: ClosureType -> Int


=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots.hs
=====================================
@@ -11,7 +11,7 @@ import GHC.Exts
 -- Invent a type to bypass the type constraints of getClosureData.
 -- Infact this will be a Word#, that is directly given to unpackClosure#
 -- (which is a primop that expects a pointer to a closure).
-data FoolStgTSO
+data FoolClosure
 
 foreign import ccall safe "list_threads_and_misc_roots_c.h listThreadsAndMiscRoots"
     listThreadsAndMiscRoots_c :: IO ()
@@ -31,28 +31,42 @@ foreign import ccall safe "list_threads_and_misc_roots_c.h getMiscRoots"
 main :: IO ()
 main = do
     listThreadsAndMiscRoots_c
+
     tsoCount <- getTSOCount_c
-    print tsoCount
     tsos <- getTSOs_c
     tsoList <- peekArray tsoCount tsos
-    tsoClosures <- sequence $ map createClosure tsoList
-    print tsoClosures
-    -- TODO: assert...
+    tsoClosures <- mapM createClosure tsoList
+    assertEqual tsoCount $ length tsoClosures
+    mapM (assertEqual TSO) $ map (tipe . info) tsoClosures
 
     miscRootsCount <- getMiscRootsCount_c
-    print miscRootsCount
     miscRoots <- getMiscRoots_c
     miscRootsList <- peekArray miscRootsCount miscRoots
-    heapClosures <- sequence $ map createClosure miscRootsList
-    print heapClosures
-    -- TODO: assert...
+    heapClosures <- mapM createClosure miscRootsList
+    assertEqual miscRootsCount $ length heapClosures
+    -- Regarding the type system, this always has to be True, but we want to
+    -- force evaluation / de-serialization with a simple check.
+    mapM assertIsClosureType $ map (tipe . info) heapClosures
 
     return ()
 
 createClosure :: Word -> IO (GenClosure Box)
 createClosure tsoPtr = do
     let wPtr = unpackWord# tsoPtr
-    getClosureData ((unsafeCoerce# wPtr) :: FoolStgTSO)
+    getClosureData ((unsafeCoerce# wPtr) :: FoolClosure)
 
 unpackWord# :: Word -> Word#
 unpackWord# (W# w#) = w#
+
+assertEqual :: (Show a, Eq a) => a -> a -> IO ()
+assertEqual a b
+    | a /= b = error (show a ++ " /= " ++ show b)
+    | otherwise = return ()
+
+assertIsClosureType :: ClosureType -> IO ()
+assertIsClosureType t
+    | t `elem` enumerate = return ()
+    | otherwise = error (show t ++ " not in  " ++ show enumerate)
+    where
+        enumerate :: [ClosureType]
+        enumerate = [minBound..maxBound]


=====================================
libraries/ghc-heap/tests/list_threads_and_misc_roots_c.c
=====================================
@@ -13,13 +13,13 @@ StgClosure** miscRoots;
 void collectTSOsCallback(void *user, StgTSO* tso){
     tsoCount++;
     tsos = realloc(tsos, sizeof(StgTSO*) * tsoCount);
-    tsos[tsoCount-1] = tso;
+    tsos[tsoCount - 1] = tso;
 }
 
 void collectMiscRootsCallback(void *user, StgClosure* closure){
     miscRootsCount++;
-    miscRoots = realloc(tsos, sizeof(StgTSO*) * miscRootsCount);
-    miscRoots[miscRootsCount-1] = closure;
+    miscRoots = realloc(miscRoots, sizeof(StgClosure*) * miscRootsCount);
+    miscRoots[miscRootsCount - 1] = closure;
 }
 
 void* listThreads_thread(void* unused){



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/237e4082a9720025621146658fbd434c1dfbcc35

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/237e4082a9720025621146658fbd434c1dfbcc35
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/20200628/298ce9fe/attachment-0001.html>