more forkLabeled, and now forkOSLabeled

1 files changed, 5 insertions, 11 deletions

diff --git a/dht/Presence/DNSCache.hs b/dht/Presence/DNSCache.hs
index e28655c5..14581fee 100644
--- a/dht/Presence/DNSCache.hs
+++ b/dht/Presence/DNSCache.hs
@@ -22,12 +22,7 @@ module DNSCache
     , withPort
     ) where
 
-#ifdef THREAD_DEBUG
-import Control.Concurrent.Lifted.Instrument
-#else
-import Control.Concurrent.Lifted
-import GHC.Conc                  (labelThread)
-#endif
+import Control.Concurrent.ThreadUtil
 import Control.Arrow
 import Control.Concurrent.STM
 import Data.Text       ( Text )
@@ -108,10 +103,10 @@ make6mapped4 :: SockAddr -> SockAddr
 make6mapped4 addr@(SockAddrInet6 {}) = addr
 make6mapped4 addr@(SockAddrInet port a) = SockAddrInet6 port 0 (0,0,0xFFFF,fromBE32 a) 0
 
-tryForkOS :: IO () -> IO ThreadId
-tryForkOS action = catchIOError (forkOS action) $ \e -> do
+tryForkOS :: String -> IO () -> IO ThreadId
+tryForkOS lbl action = catchIOError (forkOSLabeled lbl action) $ \e -> do
     dput XMisc $ "DNSCache: Link with -threaded to avoid excessively long time-out."
-    forkIO action
+    forkLabeled lbl action
 
 
 -- Attempt to resolve the given domain name.  Returns an empty list if the
@@ -126,8 +121,7 @@ rawForwardResolve ::
 rawForwardResolve dns onFail timeout addrtext = do
     r <- atomically newEmptyTMVar
     mvar <- interruptibleDelay
-    rt <- tryForkOS $ do
-        myThreadId >>= flip labelThread ("resolve."++show addrtext)
+    rt <- tryForkOS ("resolve."++show addrtext) $ do
         resolver r mvar
     startDelay mvar timeout
     did <- atomically $ tryPutTMVar r []