-setNameCache :: NameCache -> TcRnIf a b ()
-setNameCache nc = do { HscEnv { hsc_NC = nc_var } <- getTopEnv;
- writeMutVar nc_var nc }
+updNameCache :: (NameCache -> (NameCache, c)) -> TcRnIf a b c
+updNameCache upd_fn = do
+ HscEnv { hsc_NC = nc_var } <- getTopEnv
+ atomicUpdMutVar' nc_var upd_fn
+
+-- | Update the name cache, but takes a lock while the update function is
+-- running. If the update function throws an exception the lock is released
+-- and the exception propagated.
+lockedUpdNameCache :: (NameCache -> IO (NameCache, c)) -> TcRnIf a b c
+lockedUpdNameCache upd_fn = do
+ lock <- hsc_NC_lock `fmap` getTopEnv
+ -- Non-blocking "takeMVar" so we can show diagnostics if we didn't get the
+ -- lock.
+ mb_ok <- liftIO $ tryTakeMVar lock
+ case mb_ok of
+ Nothing -> do
+ traceIf (text "lockedUpdNameCache: failed to take lock. blocking..")
+ _ <- liftIO $ takeMVar lock
+ traceIf (text "lockedUpdNameCache: got lock")
+ Just _ -> return ()
+
+ name_cache <- getNameCache
+ (name_cache', rslt) <- liftIO (upd_fn name_cache
+ `onException` putMVar lock ())
+
+ nc_var <- hsc_NC `fmap` getTopEnv
+ writeMutVar nc_var $! name_cache'
+
+ liftIO (putMVar lock ())
+ return rslt