[Git][ghc/ghc][wip/ghc-debug] Parse TSO flags

[Sven Tennie]

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


Commits:
2fa1768c by Sven Tennie at 2020-08-13T08:03:56+02:00
Parse TSO flags

- - - - -


3 changed files:

- libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
- libraries/ghc-heap/tests/all.T
- + libraries/ghc-heap/tests/parse_tso_flags.hs


Changes:

=====================================
libraries/ghc-heap/GHC/Exts/Heap/FFIClosures.hsc
=====================================
@@ -8,8 +8,6 @@ import Foreign
 import GHC.Exts.Heap.ProfInfo.Types
 import GHC.Exts.Heap.Closures(WhatNext(..), WhyBlocked(..), TsoFlags(..))
 
--- TODO use sum type for what_next, why_blocked, flags?
-
 data TSOFields = TSOFields {
     tso_what_next :: WhatNext,
     tso_why_blocked :: WhyBlocked,
@@ -59,7 +57,6 @@ parseWhatNext w = case w of
                     (#const ThreadComplete) -> ThreadComplete
                     _ -> WhatNextUnknownValue
 
--- TODO: define mapping
 parseWhyBlocked :: Word16 -> WhyBlocked
 parseWhyBlocked w = case w of
                         (#const NotBlocked) -> NotBlocked
@@ -80,9 +77,22 @@ parseWhyBlocked w = case w of
 #endif
                         _ -> WhyBlockedUnknownValue
 
--- TODO: define mapping
 parseTsoFlags :: Word32 -> [TsoFlags]
-parseTsoFlags _ = []
+parseTsoFlags w | isSet (#const TSO_LOCKED) w = TsoLocked : parseTsoFlags (unset (#const TSO_LOCKED) w)
+                | isSet (#const TSO_BLOCKEX) w = TsoBlockx : parseTsoFlags (unset (#const TSO_BLOCKEX) w)
+                | isSet (#const TSO_INTERRUPTIBLE) w = TsoInterruptible : parseTsoFlags (unset (#const TSO_INTERRUPTIBLE) w)
+                | isSet (#const TSO_STOPPED_ON_BREAKPOINT) w = TsoStoppedOnBreakpoint : parseTsoFlags (unset (#const TSO_STOPPED_ON_BREAKPOINT) w)
+                | isSet (#const TSO_MARKED) w = TsoMarked : parseTsoFlags (unset (#const TSO_MARKED) w)
+                | isSet (#const TSO_SQUEEZED) w = TsoSqueezed : parseTsoFlags (unset (#const TSO_SQUEEZED) w)
+                | isSet (#const TSO_ALLOC_LIMIT) w = TsoAllocLimit : parseTsoFlags (unset (#const TSO_ALLOC_LIMIT) w)
+parseTsoFlags 0 = []
+parseTsoFlags _ = [TsoFlagsUnknownValue]
+
+isSet :: Word32 -> Word32 -> Bool
+isSet bitMask w = w .&. bitMask /= 0
+
+unset :: Word32 -> Word32 -> Word32
+unset bitMask w = w `xor` bitMask
 
 data StackFields = StackFields {
     stack_size :: Word32,


=====================================
libraries/ghc-heap/tests/all.T
=====================================
@@ -58,3 +58,11 @@ test('prof_info',
       only_ways(prof_ways)
      ],
      multi_compile_and_run, ['prof_info', [('create_tso.c','')], '-prof'])
+
+test('parse_tso_flags',
+     [extra_files(['TestUtils.hs']),
+      only_ways(['normal']),
+      ignore_stdout,
+      ignore_stderr
+     ],
+     compile_and_run, [''])


=====================================
libraries/ghc-heap/tests/parse_tso_flags.hs
=====================================
@@ -0,0 +1,17 @@
+import GHC.Exts.Heap.Closures
+import GHC.Exts.Heap.FFIClosures
+import TestUtils
+
+main :: IO()
+main = do
+    assertEqual (parseTsoFlags 0) []
+    assertEqual (parseTsoFlags 1) [TsoFlagsUnknownValue]
+    assertEqual (parseTsoFlags 2) [TsoLocked]
+    assertEqual (parseTsoFlags 4) [TsoBlockx]
+    assertEqual (parseTsoFlags 8) [TsoInterruptible]
+    assertEqual (parseTsoFlags 16) [TsoStoppedOnBreakpoint]
+    assertEqual (parseTsoFlags 64) [TsoMarked]
+    assertEqual (parseTsoFlags 128) [TsoSqueezed]
+    assertEqual (parseTsoFlags 256) [TsoAllocLimit]
+
+    assertEqual (parseTsoFlags 6) [TsoLocked, TsoBlockx]



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fa1768cbcafb24e08f21ee479bf1ce11d53ac27

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2fa1768cbcafb24e08f21ee479bf1ce11d53ac27
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/20200813/998ba58f/attachment-0001.html>