[Git][ghc/ghc][wip/T19078] Test start/endEventlogging: first header must be EVENT_HEADER_BEGIN

[David Eichmann]

David Eichmann pushed to branch wip/T19078 at Glasgow Haskell Compiler / GHC


Commits:
38b14b7e by David Eichmann at 2020-12-17T18:51:59+00:00
Test start/endEventlogging: first header must be EVENT_HEADER_BEGIN

- - - - -


4 changed files:

- + testsuite/tests/rts/RestartEventLogging.hs
- + testsuite/tests/rts/RestartEventLogging.stdout
- + testsuite/tests/rts/RestartEventLogging_c.c
- testsuite/tests/rts/all.T


Changes:

=====================================
testsuite/tests/rts/RestartEventLogging.hs
=====================================
@@ -0,0 +1,35 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+import System.IO
+
+import Control.Concurrent
+import Control.Monad (forever, void)
+import GHC.Conc
+
+
+-- Test that the start/end/restartEventLog interface works as expected.
+main :: IO ()
+main = do
+
+  --
+  -- Start other threads to generate some event log events.
+  --
+
+  let loop f = void $ forkIO $ forever (f >> yield)
+
+  -- start lots of short lived threads
+  loop (forkIO $ yield)
+
+  -- sparks
+  loop (let x = 1 + (1 :: Int) in return (par x (sum [0,1,2,3,x])))
+
+  --
+  -- Try restarting event logging a few times.
+  --
+
+  putStrLn "Restarting eventlog..."
+  hFlush stdout
+  c_restart_eventlog
+
+foreign import ccall safe "c_restart_eventlog"
+  c_restart_eventlog :: IO ()


=====================================
testsuite/tests/rts/RestartEventLogging.stdout
=====================================
@@ -0,0 +1,65 @@
+Restarting eventlog...
+failed to start eventlog
+init
+Event log started with EVENT_HEADER_BEGIN
+write
+write
+write
+write
+stop
+init
+Event log started with EVENT_HEADER_BEGIN
+write
+write
+write
+write
+stop
+init
+Event log started with EVENT_HEADER_BEGIN
+write
+write
+write
+write
+stop
+init
+Event log started with EVENT_HEADER_BEGIN
+write
+write
+write
+write
+stop
+init
+Event log started with EVENT_HEADER_BEGIN
+write
+write
+write
+write
+stop
+init
+Event log started with EVENT_HEADER_BEGIN
+write
+write
+write
+write
+stop
+init
+Event log started with EVENT_HEADER_BEGIN
+write
+write
+write
+write
+stop
+init
+Event log started with EVENT_HEADER_BEGIN
+write
+write
+write
+write
+stop
+init
+Event log started with EVENT_HEADER_BEGIN
+write
+write
+write
+write
+stop


=====================================
testsuite/tests/rts/RestartEventLogging_c.c
=====================================
@@ -0,0 +1,78 @@
+#include <stdio.h>
+#include <Rts.h>
+#include <rts/EventLogFormat.h>
+
+#define STOPPED       0
+#define STARTED       1
+#define WRITTEN       2
+
+static int32_t state = STOPPED;
+
+void test_init(void) {
+  if (state != STOPPED) {
+    printf("test_init was not called first or directly after test_stop\n");
+  }
+
+  state = STARTED;
+  printf("init\n");
+  fflush(stdout);
+}
+
+bool test_write(void *eventlog, size_t eventlog_size) {
+  if (state == STOPPED) {
+    printf("test_init was not called\n");
+  }
+  if (state == STARTED) {
+    // Note that the encoding of the header is coppied from EventLog.c (see `postInt32()`)
+    StgWord8 * words = (StgWord8 *)eventlog;
+    StgInt32 h32 = EVENT_HEADER_BEGIN;
+    StgWord32 h = (StgWord32)h32; // Yes, the cast is correct. See `postInt32()`
+    if ((words[0] != (StgWord8)(h >> 24))
+        || (words[1] != (StgWord8)(h >> 16))
+        || (words[2] != (StgWord8)(h >> 8))
+        || (words[3] != (StgWord8)h)) {
+      printf("ERROR: event does not start with EVENT_HEADER_BEGIN\n");
+      printf("0x%x != 0x%x\n", words[0], (StgWord8)(h >> 24));
+      printf("0x%x != 0x%x\n", words[1], (StgWord8)(h >> 16));
+      printf("0x%x != 0x%x\n", words[2], (StgWord8)(h >> 8));
+      printf("0x%x != 0x%x\n", words[3], (StgWord8)h);
+    }
+    else {
+      printf("Event log started with EVENT_HEADER_BEGIN\n");
+    }
+  }
+
+  state = WRITTEN;
+
+  printf("write\n");
+  fflush(stdout);
+  return true;
+}
+
+void test_flush(void) {
+  printf("flush\n");
+  fflush(stdout);
+}
+
+void test_stop(void) {
+  state = STOPPED;
+  printf("stop\n");
+  fflush(stdout);
+}
+
+const EventLogWriter writer = {
+  .initEventLogWriter = test_init,
+  .writeEventLog = test_write,
+  .flushEventLog = test_flush,
+  .stopEventLogWriter = test_stop
+};
+
+void c_restart_eventlog(void) {
+  for (int i = 0; i < 10; i++) {
+    if (!startEventLogging(&writer)) {
+      printf("failed to start eventlog\n");
+    }
+    endEventLogging();
+  }
+}
+


=====================================
testsuite/tests/rts/all.T
=====================================
@@ -419,6 +419,9 @@ test('T13676',
 test('InitEventLogging',
      [only_ways(['normal']), extra_run_opts('+RTS -RTS')],
      compile_and_run, ['-eventlog InitEventLogging_c.c'])
+test('RestartEventLogging',
+     [only_ways(['threaded1','threaded2']), extra_run_opts('+RTS -la -RTS')],
+     compile_and_run, ['-eventlog RestartEventLogging_c.c'])
 
 test('T17088',
      [only_ways(['normal']), extra_run_opts('+RTS -c -A256k -RTS')],



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/38b14b7e53173cf9e22870674793fd23c6fe1904

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/38b14b7e53173cf9e22870674793fd23c6fe1904
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/20201217/bfb16259/attachment-0001.html>