More sensible DNSCache behavior for non-threaded runtime.

1 files changed, 14 insertions, 3 deletions

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))