@@ -2,8 +2,10 @@
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE MagicHash #-}
56{-# LANGUAGE MultiParamTypeClasses #-}
67{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE UnboxedTuples #-}
79{-# LANGUAGE UndecidableInstances #-} -- XXX
810
911-- |
@@ -64,8 +66,7 @@ module Streamly.Core
6466 )
6567where
6668
67−import Control.Concurrent (ThreadId, forkIO,
68− myThreadId, threadDelay)
69+import Control.Concurrent (ThreadId, myThreadId, threadDelay)
6970import Control.Concurrent.MVar (MVar, newEmptyMVar, tryTakeMVar,
7071 tryPutMVar, takeMVar)
7172import Control.Exception (SomeException (..))
@@ -90,6 +91,10 @@ import Data.Set (Set)
9091import qualified Data.Set as S
9192import Prelude hiding (repeat, zipWith)
9293
94+import GHC.Exts
95+import GHC.Conc (ThreadId(..))
96+import GHC.IO (IO(..))
97+
9398------------------------------------------------------------------------------
9499-- Parent child thread communication type
95100------------------------------------------------------------------------------
@@ -255,6 +260,16 @@ type MonadParallel m = (MonadIO m, MonadBaseControl IO m, MonadThrow m)
255260{-# DEPRECATED MonadAsync "Please use MonadParallel instead." #-}
256261type MonadAsync m = MonadParallel m
257262
263+-- Stolen from the async package. The perf improvement is modest, 2% on a
264+-- thread heavy benchmark (parallel composition using noop computations).
265+-- A version of forkIO that does not include the outer exception
266+-- handler: saves a bit of time when we will be installing our own
267+-- exception handler.
268+{-# INLINE rawForkIO #-}
269+rawForkIO :: IO () -> IO ThreadId
270+rawForkIO action = IO $ \ s ->
271+ case (fork# action s) of (# s1, tid #) -> (# s1, ThreadId tid #)
272+
258273{-# INLINE doFork #-}
259274doFork :: MonadBaseControl IO m
260275 => m ()
@@ -262,7 +277,7 @@ doFork :: MonadBaseControl IO m
262277 -> m ThreadId
263278doFork action exHandler =
264279 EL.mask $ \restore ->
265− liftBaseWith $ \runInIO -> forkIO $ do
280+ liftBaseWith $ \runInIO -> rawForkIO $ do
266281 _ <- runInIO $ EL.catch (restore action) exHandler
267282 -- XXX restore state here?
268283 return ()