From 69e0c86ff42f9f14c16791305828dcfdfd40baa8 Mon Sep 17 00:00:00 2001
From: joe <joe@jerkface.net>
Date: Tue, 14 Nov 2017 22:03:27 -0500
Subject: More sensible DNSCache behavior for non-threaded runtime.

---
 src/Control/Concurrent/Lifted/Instrument.hs | 17 ++++++++++++++---
 1 file changed, 14 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/Control/Concurrent/Lifted/Instrument.hs b/src/Control/Concurrent/Lifted/Instrument.hs
index 7e4a7356..41814d98 100644
--- a/src/Control/Concurrent/Lifted/Instrument.hs
+++ b/src/Control/Concurrent/Lifted/Instrument.hs
@@ -2,6 +2,7 @@
 module Control.Concurrent.Lifted.Instrument
     ( module Control.Concurrent.Lifted
     , forkIO
+    , forkOS
     , fork
     , labelThread
     , threadsInformation
@@ -9,7 +10,7 @@ module Control.Concurrent.Lifted.Instrument
     ) where
 
 import qualified Control.Concurrent.Lifted as Raw
-import Control.Concurrent.Lifted hiding (fork)
+import Control.Concurrent.Lifted hiding (fork,forkOS)
 import Control.Exception (fromException)
 import Control.Monad.Trans.Control
 import System.IO.Unsafe
@@ -46,9 +47,19 @@ forkIO :: IO () -> IO ThreadId
 forkIO = fork
 {-# INLINE forkIO #-}
 
+forkOS :: (MonadBaseControl IO m, MonadIO m) => m () -> m ThreadId
+forkOS = instrumented Raw.forkOS
+{-# INLINE forkOS #-}
+
 fork :: (MonadBaseControl IO m, MonadIO m) => m () -> m ThreadId
-fork action = do
-    t <- Raw.fork $ do
+fork = instrumented Raw.fork
+{-# INLINE fork #-}
+
+instrumented :: ( MonadBaseControl IO m
+                , MonadIO m) =>
+                (m () -> m ThreadId) -> m () -> m ThreadId
+instrumented rawFork action = do
+    t <- rawFork $ do
         tid <- myThreadId
         tm <- liftBase getCurrentTime
         bracket_ (modifyThreads $! Map.insert tid (PerThread "" tm))
-- 
cgit v1.2.3