[Git][ghc/ghc][wip/ghc-debug] Add test for StgTSO decoding

[Sven Tennie]

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


Commits:
8f2d54da by Sven Tennie at 2020-06-01T19:12:45+02:00
Add test for StgTSO decoding

- - - - -


4 changed files:

- libraries/ghc-heap/tests/all.T
- + libraries/ghc-heap/tests/create_tso.c
- + libraries/ghc-heap/tests/create_tso.h
- + libraries/ghc-heap/tests/tso_and_stack_closures.hs


Changes:

=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -36,3 +36,9 @@ test('closure_size_noopt',
      ],
      compile_and_run, [''])
 
+test('tso_and_stack_closures',
+     [extra_files(['create_tso.c','create_tso.h']),
+      ignore_stdout,
+      ignore_stderr
+     ],
+     multi_compile_and_run, ['tso_and_stack_closures', [('create_tso.c','')], ''])


=====================================
libraries/ghc-heap/tests/create_tso.c
=====================================
@@ -0,0 +1,10 @@
+#include "Rts.h"
+#include "RtsAPI.h"
+
+StgTSO* create_tso(){
+    HaskellObj trueClosure = rts_mkBool(&MainCapability, 1);
+
+    StgTSO * tso = createGenThread(&MainCapability, 500U, trueClosure);
+
+    return tso;
+}


=====================================
libraries/ghc-heap/tests/create_tso.h
=====================================
@@ -0,0 +1,3 @@
+#include "RtsAPI.h"
+
+StgTSO* create_tso();


=====================================
libraries/ghc-heap/tests/tso_and_stack_closures.hs
=====================================
@@ -0,0 +1,41 @@
+{-# LANGUAGE ForeignFunctionInterface, MagicHash, CPP #-}
+
+import Foreign
+import Foreign.C.Types
+import GHC.Exts.Heap
+import GHC.Exts
+
+import GHC.Word
+
+#include "ghcconfig.h"
+#include "rts/Constants.h"
+
+foreign import ccall unsafe "create_tso.h create_tso"
+    c_create_tso:: IO Word
+
+-- 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
+
+main :: IO ()
+main = do
+    ptr <- c_create_tso
+    let wPtr = unpackWord# ptr
+    tso <- getClosureData ((unsafeCoerce# wPtr) :: FoolStgTSO)
+
+    assertEqual (what_next tso) ThreadRunGHC
+    assertEqual (why_blocked tso) NotBlocked
+    assertEqual (saved_errno tso) 0
+
+-- todo (sven): assert more?
+
+    print $ "tso : "++ show tso
+
+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 ()



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f2d54da3b23ef2e56c993126edb09b5788e870b

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8f2d54da3b23ef2e56c993126edb09b5788e870b
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/20200601/b410d1eb/attachment-0001.html>