packages feed

ghc-eventlog-loopback (empty) → 0.1.0.0

raw patch · 6 files changed

+311/−0 lines, 6 filesdep +basedep +bytestringdep +ghc-eventlog-loopback

Dependencies added: base, bytestring, ghc-eventlog-loopback, ghc-events

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for ghc-eventlog-loopback++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2024, Teo Camarasu++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Teo Camarasu nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ cbits/writer.c view
@@ -0,0 +1,125 @@+#include <string.h>+#include <Rts.h>++struct queue_entry {+    size_t entry_length;+    void* entry_contents;+    struct queue_entry* entry_next;+};++// Global state+static int loopback_cap = -1;+static HsStablePtr loopback_mvar = NULL;+static struct queue_entry * queue = NULL;+static Mutex loopback_mutex;++// Signal to the listening thread that there are chunks to read+void tryWakeup(void)+{+    if(loopback_mvar) {+      hs_try_putmvar(loopback_cap, loopback_mvar);+      loopback_mvar = NULL;+    }+}++void registerWakeup(int cap, HsStablePtr mvar)+{+    loopback_cap = cap;+    loopback_mvar = mvar;+    // immediately wake it up if the queue is not empty+    if (queue) {+        tryWakeup();+    }+}++void pushChunk(void* chunk, size_t chunk_size)+{+    ACQUIRE_LOCK(loopback_mutex);+    struct queue_entry* tail = queue;+    // This is O(N) #1 should fix this+    while(tail && tail->entry_next) {+      tail = tail->entry_next;+    }+    struct queue_entry* entry = malloc(sizeof(struct queue_entry));+    entry->entry_length = chunk_size;+    entry->entry_contents = chunk;+    entry->entry_next = NULL;+    if(tail) {+        // append to the end of the queue+        ASSERT(tail->entry_next == NULL);+        tail->entry_next = entry;+    } else {+        // queue is empty+        queue = entry;+    }+    RELEASE_LOCK(loopback_mutex);+}++void freeChunk(struct queue_entry* entry)+{+    if(entry){+        // entry->entry_contents will be freed on the Haskell side+        free(entry);+    }+}++struct queue_entry* popChunk()+{+    ACQUIRE_LOCK(loopback_mutex);+    struct queue_entry* entry = queue;+    if(entry) {+        queue = entry->entry_next;+    }+    RELEASE_LOCK(loopback_mutex);+    return entry;+}++// Initialise the loopback writer+void loopback_init(void)+{+    initMutex(&loopback_mutex);+}++bool loopback_write(void* eventlog, size_t eventlog_size)+{+    void* chunk = malloc(eventlog_size);+    memcpy(chunk, eventlog, eventlog_size);+    pushChunk(chunk, eventlog_size);+    tryWakeup();+    return true;+}++void loopback_flush(void)+{+}++void loopback_stop(void)+{+    loopback_cap = -1;+    loopback_mvar = NULL;+    // TODO: free everything on the queue?+    queue = NULL;+#if defined(THREADED_RTS)+    closeMutex(&loopback_mutex);+#endif+}++EventLogWriter loopback_writer = {+ .initEventLogWriter = loopback_init,+ .writeEventLog = loopback_write,+ .flushEventLog = loopback_flush,+ .stopEventLogWriter = loopback_stop+};+++void startLoopbackWriter(void)+{+    endEventLogging();+    startEventLogging(&loopback_writer);+}++void stopLoopbackWriter(void)+{+    loopback_stop();+    endEventLogging();+}
+ ghc-eventlog-loopback.cabal view
@@ -0,0 +1,50 @@+cabal-version:      3.0+name:               ghc-eventlog-loopback+version:            0.1.0.0+synopsis:           Let an application read its own eventlog+description:        Let an application read its own eventlog+license:            BSD-3-Clause+license-file:       LICENSE+author:             Teo Camarasu+maintainer:         teofilcamarasu@gmail.com+copyright:          ghc-eventlog-loopback contributors+category:           Development+build-type:         Simple+extra-doc-files:    CHANGELOG.md+bug-reports:        https://codeberg.org/teo/ghc-eventlog-loopback/issues+tested-with:+  GHC ==9.2.8+  ||  ==9.4.7+  ||  ==9.6.7+  ||  ==9.8.4+  ||  ==9.10.3+  ||  ==9.12.2++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  GHC.RTS.Events.Loopback+    c-sources: cbits/writer.c+    build-depends:+      base >=4.16 && <4.23,+      bytestring >=0.11 && <0.13+    hs-source-dirs:   src+    default-language: Haskell2010++test-suite test+    import:           warnings+    default-language: Haskell2010+    type:             exitcode-stdio-1.0+    hs-source-dirs:   test+    main-is:          Main.hs+    ghc-options: -eventlog -threaded -with-rtsopts "-N2 -la"+    build-depends:+        base,+        ghc-events,+        ghc-eventlog-loopback++source-repository head+  type:     git+  location: https://codeberg.org/teo/ghc-eventlog-loopback.git
+ src/GHC/RTS/Events/Loopback.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeApplications #-}+module GHC.RTS.Events.Loopback+  ( start+  , stop+  , readEventLogChunk+  ) where++import Foreign.StablePtr+import Foreign.Ptr+import Foreign.ForeignPtr+import GHC.Conc+import Foreign.Storable+import Foreign.Marshal.Alloc+import Data.ByteString.Internal+import Data.Word+import Control.Concurrent++foreign import ccall "startLoopbackWriter" startLoopbackWriter :: IO ()+foreign import ccall "stopLoopbackWriter" stopLoopbackWriter :: IO ()+foreign import ccall "registerWakeup" registerWakeup :: Int -> StablePtr PrimMVar -> IO ()+foreign import ccall "popChunk" popChunk :: IO (Ptr Int)+foreign import ccall "freeChunk" freeChunk :: Ptr Int-> IO ()++-- | Replace the built-in eventlog backend with the loopback backend.+start :: IO ()+start = startLoopbackWriter++-- | Read an eventlog chunk. If no chunks are available then this function will block.+-- The 'ByteString' chunks can then be fed to the parser from @ghc-events@.+readEventLogChunk :: IO ByteString+readEventLogChunk = do+  entryPtr <- popChunk+  if nullPtr == entryPtr+    then do+      -- if we there are no chunks,+      -- then register a wakeup call for when we get one.+      mvar <- newEmptyMVar @()+      sp <- newStablePtrPrimMVar mvar+      (cap, _) <- threadCapability =<< myThreadId+      registerWakeup cap sp+      takeMVar mvar+      -- Try again, since we've got some chunks now+      readEventLogChunk+    else do+      size <- peek @Int entryPtr+      ptr <- peek @(Ptr Word8) (entryPtr `plusPtr` (sizeOf (undefined :: Int)))+      fptr <- newForeignPtr finalizerFree ptr+      freeChunk entryPtr+      pure $ BS fptr size++-- | Stop the loopback eventlog backend.+stop :: IO ()+stop = stopLoopbackWriter
+ test/Main.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import GHC.RTS.Events.Loopback+import Control.Monad+import Debug.Trace+import Data.IORef+import Control.Concurrent+import System.Exit++import GHC.RTS.Events.Incremental+import GHC.RTS.Events (EventInfo(UserMessage), evSpec)+++main :: IO ()+main = do+  state <- newIORef decodeEventLog+  events <- newIORef []+  let go bs = do+        s <- readIORef state+        let s' = case s of+                    Consume feed -> feed bs+                    _ -> error "impossible"+        s'' <- produceAll s'+        writeIORef state $! s''+      produceAll (Produce ev k) = modifyIORef' events (ev:) >> produceAll k+      produceAll (Error _ emsg) = error $ "Failed to parse: " ++ emsg+      produceAll k = pure k+  start+  void . forkIO . forever $ readEventLogChunk >>= go+  traceEventIO "foo bar baz"+  flushEventLog+  traceEventIO "foo bar baz"+  flushEventLog+  threadDelay 100+  evs <- readIORef events+  case length . filter (findExpectedMessage . evSpec) $ evs of+    2 -> putStrLn "Success" >> exitSuccess+    x -> do+      putStrLn $ "expected 2 but got " ++ show x+      exitFailure++findExpectedMessage :: EventInfo -> Bool+findExpectedMessage (UserMessage "foo bar baz") = True+findExpectedMessage _ = False